(* week-15_a-commutative-diagram.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Spelled-out version of Sun 26 Nov 2017 *)
(* was: *)
(* Version of Sat 25 Nov 2017 *)

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

(*
   name: Oishik Ganguly
   student ID number: A0138306J
   e-mail address: oishik.ganguly@u.yale-nus.edu.sg
*)

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

The goal of this term project is to prove the following theorem:

  Theorem the_commutative_diagram :
    forall sp : source_program,
      interpret sp = run (compile sp).

for

* a source language of arithmetic expressions:

    Inductive arithmetic_expression : Type :=
    | Literal : nat -> arithmetic_expression
    | Plus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression
    | Minus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression.

    Inductive source_program : Type :=
    | Source_program : arithmetic_expression -> source_program.

* a target language of byte-code instructions:

    Inductive byte_code_instruction : Type :=
    | PUSH : nat -> byte_code_instruction
    | ADD : byte_code_instruction
    | SUB : byte_code_instruction.

    Inductive target_program : Type :=
    | Target_program : list byte_code_instruction -> target_program.

* a semantics of expressible values:

    Inductive expressible_value : Type :=
    | Expressible_nat : nat -> expressible_value
    | Expressible_msg : string -> expressible_value.

The source for errors is subtraction,
since subtracting two natural numbers does not always yield a natural number:
for example, 3 - 2 is defined but not 2 - 3.

You are expected, at the very least:

* to implement a source interpreter
  and to verify that it satisfies its specification

* to implement a target interpreter (i.e., a virtual machine)
  and to verify that it satisfies its specification

* to implement a compiler
  and to verify that it satisfies its specification

* to prove that the diagram commutes, i.e., to show that
  interpreting any given expression
  gives the same result as
  compiling this expression and then running the resulting compiled program
  (to this end, the injection tactic illustrated in Lemma new_and_useful just below will come handy)

Beyond this absolute minimum, in decreasing importance, it would be good:

* to write an accumulator-based compiler and to prove that it satisfies the specification

* to investigate byte-code verification

* to revisit good old Magritte

* to write a continuation-based interpreter and to prove that it satisfies the specification

* to prove that each of the specifications specifies a unique function

*)

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

Lemma new_and_useful :
  forall i j : nat,
    Some i = Some j -> i = j.
Proof.
  intros i j H_Some.
  injection H_Some as H_i_j.  (* <--[new and useful]-- *)
  exact H_i_j.
Qed.

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

Ltac unfold_tactic name :=
  intros;
  unfold name; (* fold name; *)
  reflexivity.

Require Import Arith Bool List String.

(* n2 > n1 ? *)
Fixpoint ltb (n1 n2 : nat) : bool :=
  match n1 with
  | O =>
    match n2 with
    | O =>
      false
    | S n2' =>
      true
    end
  | S n1' =>
    match n2 with
    | O =>
      false
    | S n2' =>
      ltb n1' n2'
    end
  end.

Notation "A =n= B" := (beq_nat A B) (at level 70, right associativity).

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

(* Arithmetic expressions: *)

Inductive arithmetic_expression : Type :=
| Literal : nat -> arithmetic_expression
| Plus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression
| Minus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression.

(* Source programs: *)

Inductive source_program : Type :=
| Source_program : arithmetic_expression -> source_program.

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

(* Semantics: *)

Inductive expressible_value : Type :=
| Expressible_msg : string -> expressible_value
| Expressible_nat : nat -> expressible_value.

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

(* Task 1:
   prove that each of the definitions below specifies a unique function,
   implement these two functions,
   and verify that each of your functions satisfies its specification.
 *)

(* We first define a notion of equality for expressible values *)

Definition expressible_val_eq (e1 : expressible_value) (e2 : expressible_value) :=
  match e1 with
  | Expressible_nat n1 =>
    match e2 with
    | Expressible_nat n2 =>
      n1 =n= n2
    | _ =>
      false
    end
  | Expressible_msg _ =>
    match e2 with
    | Expressible_msg _ =>
      true
    | _ =>
      false
    end
  end.

Notation "A =e= B" := (expressible_val_eq A B) (at level 70, right associativity).

Definition specification_of_evaluate (evaluate : arithmetic_expression -> expressible_value) :=
  (forall n : nat,
      (* specification for literals *)
     evaluate (Literal n) = Expressible_nat n)
  /\
  ((forall (ae1 ae2 : arithmetic_expression)
           (s1 : string),
       evaluate ae1 = Expressible_msg s1 ->
       evaluate (Plus ae1 ae2) = Expressible_msg s1)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 : nat)
           (s2 : string),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_msg s2 ->
       evaluate (Plus ae1 ae2) = Expressible_msg s2)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 n2 : nat),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_nat n2 ->
       evaluate (Plus ae1 ae2) = Expressible_nat (n1 + n2)))
  /\
  ((forall (ae1 ae2 : arithmetic_expression)
           (s1 : string),
       evaluate ae1 = Expressible_msg s1 ->
       evaluate (Minus ae1 ae2) = Expressible_msg s1)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 : nat)
           (s2 : string),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_msg s2 ->
       evaluate (Minus ae1 ae2) = Expressible_msg s2)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 n2 : nat),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_nat n2 ->
       ltb n1 n2 = true ->
       evaluate (Minus ae1 ae2) = Expressible_msg "numerical underflow")
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 n2 : nat),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_nat n2 ->
       ltb n1 n2 = false ->
       evaluate (Minus ae1 ae2) = Expressible_nat (n1 - n2))).

(* Proving that specification_of_evaluate is sound *)
Theorem specification_of_evaluate_is_sound :
  forall (ev1 ev2 : arithmetic_expression -> expressible_value),
    specification_of_evaluate ev1 ->
    specification_of_evaluate ev2 ->
    forall (ae : arithmetic_expression),
      ev1 ae = ev2 ae.
Proof.
  intros ev1 ev2.
  unfold specification_of_evaluate.
  intros
    [ev1_lit [[ev1_add_err_arg1 [ev1_add_err_arg2 ev1_add_eval]]
                [ev1_sub_err_arg1 [ev1_sub_err_arg2 [ev1_sub_err_ufl ev1_sub_eval]]]]]
    [ev2_lit [[ev2_add_err_arg1 [ev2_add_err_arg2 ev2_add_eval]]
                [ev2_sub_err_arg1 [ev2_sub_err_arg2 [ev2_sub_err_ufl ev2_sub_eval]]]]].
  intro ae.
  (* our proof will proceed by structural induction over arithmetic expressions *)
  induction ae as [ n' | e1 IH_e1 e2 IH_e2 | e1 IH_e1 e2 IH_e2].

  (* proof for literals *)
  rewrite -> (ev1_lit n').
  rewrite -> (ev2_lit n').
  reflexivity.

  (* proof for addition expressions *)
  (* we consider all possible evaluations of the subexpression e1 and e2 *)
  (* case 1: e1 evaluates to a string *)
  case (ev2 e1) as [str_val_e1 | nat_val_e1] eqn : e1_eval_case.
  rewrite -> (ev1_add_err_arg1 e1 e2 str_val_e1 IH_e1).
  rewrite -> (ev2_add_err_arg1 e1 e2 str_val_e1 e1_eval_case).
  reflexivity.
  (* case 2: e1 is a natural value, and e2 evaluates to a string *)
  case (ev2 e2) as [str_val_e2 | nat_val_e2] eqn : e2_eval_case.
  rewrite -> (ev1_add_err_arg2 e1 e2 nat_val_e1 str_val_e2 IH_e1 IH_e2).
  rewrite -> (ev2_add_err_arg2 e1 e2 nat_val_e1 str_val_e2 e1_eval_case e2_eval_case).
  reflexivity.
  (* case 3: both e1, e2 evaluate to natural values *)
  rewrite -> (ev1_add_eval e1 e2 nat_val_e1 nat_val_e2 IH_e1 IH_e2).
  rewrite -> (ev2_add_eval e1 e2 nat_val_e1 nat_val_e2 e1_eval_case e2_eval_case).
  reflexivity.

  (* proof for subtraction expressions; once again, consider all possible evaluated
   * cases of the expression e1 and e2 *)
  (* case 1: e1 evaluates to a string *)
  case (ev2 e1) as [str_val_e1 | nat_val_e1] eqn : e1_eval_case.
  rewrite -> (ev1_sub_err_arg1 e1 e2 str_val_e1 IH_e1).
  rewrite -> (ev2_sub_err_arg1 e1 e2 str_val_e1 e1_eval_case).
  reflexivity.
  (* case 2: e1 is a natural value, and e2 evaluates to a string *)
  case (ev2 e2) as [str_val_e2 | nat_val_e2] eqn : e2_eval_case.
  rewrite -> (ev1_sub_err_arg2 e1 e2 nat_val_e1 str_val_e2 IH_e1 IH_e2).
  rewrite -> (ev2_sub_err_arg2 e1 e2 nat_val_e1 str_val_e2 e1_eval_case e2_eval_case).
  reflexivity.
  (* case 3: both e1 and e2 are natural values, but n1 < n2 *)
  case (ltb nat_val_e1 nat_val_e2) eqn : ltb_bool_val.
  rewrite -> (ev1_sub_err_ufl e1 e2 nat_val_e1 nat_val_e2 IH_e1 IH_e2 ltb_bool_val).
  rewrite -> (ev2_sub_err_ufl e1 e2 nat_val_e1 nat_val_e2 e1_eval_case e2_eval_case
                              ltb_bool_val).
  reflexivity.
  (* case 4: both e1 and e2 and natural values, and n1 > n2 *)
  rewrite -> (ev1_sub_eval e1 e2 nat_val_e1 nat_val_e2 IH_e1 IH_e2).
  rewrite -> (ev2_sub_eval e1 e2 nat_val_e1 nat_val_e2 e1_eval_case e2_eval_case).
  reflexivity.
  exact ltb_bool_val.
  exact ltb_bool_val.
Qed.

(* Implement unit tests for evaluators *)
Definition unit_test_for_evaluate
           (evaluate : arithmetic_expression -> expressible_value) : bool :=
  (evaluate
     (Plus (Literal 2)
           (Literal 3)) =e= Expressible_nat 5)
    &&
    (evaluate
       (Minus (Literal 7)
              (Plus (Literal 5)
                    (Minus (Literal 5) (Literal 4))
              )
       ) =e= Expressible_nat 1)
    &&
    (evaluate
       ( Plus (Literal 5)
              (Plus (Literal 6)
                    (Minus (Literal 4) (Literal 6))
              )
       ) =e= Expressible_msg "numerical underflow")
    &&
    (evaluate
        ( Minus (Literal 21)
                (Plus (Literal 4)
                      (Minus
                         (Plus (Literal 14)
                               (Literal 1)
                         )
                         (Literal 10)
                      )
                )
        ) =e= Expressible_nat 12)
    &&
    (evaluate
       (Plus
          (Plus (Literal 3)
                (Minus (Literal 6)
                       (Literal 7)
                )
          )
          (Literal 3)
       ) =e= Expressible_msg "numerical underflow").

(* Naive recursive implementation of evaluate *)
Fixpoint evaluate_v0 (ae : arithmetic_expression) : expressible_value :=
  match ae with
  | Literal n =>
    Expressible_nat n
  | Plus e1 e2 =>
    (* evaluate the first expression *)
    match (evaluate_v0 e1) with
    | Expressible_msg s =>
      Expressible_msg s
    (* If the first expression is a natural value, evaluate the second expression **)
    | Expressible_nat n1 =>
      match (evaluate_v0 e2) with
      | Expressible_msg s =>
        Expressible_msg s
      | Expressible_nat n2 =>
        Expressible_nat (n1 + n2)
      end
    end
  | Minus e1 e2 =>
    match (evaluate_v0 e1) with
    | Expressible_msg s =>
      Expressible_msg s
    | Expressible_nat n1 =>
      match (evaluate_v0 e2) with
      | Expressible_msg s =>
        Expressible_msg s
      | Expressible_nat n2 =>
        (* now check whether n1 < n2 *)
        if (ltb n1 n2)
        then Expressible_msg "numerical underflow"
        else Expressible_nat (n1 - n2)
      end
    end
  end.

(* Unit test *)
Compute (unit_test_for_evaluate (evaluate_v0)).

(* Standard unfold lemmas *)
Lemma unfold_evaluate_v0_literal :
  forall (n : nat),
    evaluate_v0 (Literal n) = Expressible_nat n.
Proof.
  unfold_tactic evaluate_v0.
Qed.

Lemma unfold_evaluate_v0_plus :
  forall (e1 e2 : arithmetic_expression),
    evaluate_v0 (Plus e1 e2) =
    (match (evaluate_v0 e1) with
    | Expressible_msg s =>
      Expressible_msg s
    | Expressible_nat n1 =>
      match (evaluate_v0 e2) with
      | Expressible_msg s =>
        Expressible_msg s
      | Expressible_nat n2 =>
        Expressible_nat (n1 + n2)
      end
    end).
Proof.
  unfold_tactic evaluate_v0.
Qed.

Lemma unfold_evaluate_v0_minus :
  forall (e1 e2 : arithmetic_expression),
    evaluate_v0 (Minus e1 e2) =
    (match (evaluate_v0 e1) with
    | Expressible_msg s =>
      Expressible_msg s
    | Expressible_nat n1 =>
      match (evaluate_v0 e2) with
      | Expressible_msg s =>
        Expressible_msg s
      | Expressible_nat n2 =>
        (* now check whether n1 < n2 *)
        if (ltb n1 n2)
        then Expressible_msg "numerical underflow"
        else Expressible_nat (n1 - n2)
      end
     end).
Proof.
  unfold_tactic evaluate_v0.
Qed.

(* Proving that evaluate_v0 meets the specification_of_evaluate, thereby proving
 * that specification_of_evaluate is complete *)
Theorem evaluate_v0_meets_the_specification_of_evaluate :
  specification_of_evaluate evaluate_v0.
Proof.
  unfold specification_of_evaluate.

  (* literal *)
  split.
  intro n.
  exact (unfold_evaluate_v0_literal n).

  (* Plus : error on arg 1 *)
  split.
  split.
  intros ae1 ae2 s1 H_about_ae1.
  (* use any value to instantiate the natural values in the unfold lemma *)
  rewrite -> (unfold_evaluate_v0_plus ae1 ae2).
  rewrite -> H_about_ae1.
  reflexivity.

  (* Plus : error on arg 2 *)
  split.
  intros ae1 ae2 n1 s2 H_about_ae1 H_about_ae2.
  rewrite -> (unfold_evaluate_v0_plus ae1 ae2).
  rewrite -> H_about_ae1 ; rewrite -> H_about_ae2.
  reflexivity.

  (* Plus : both args evaluate to expressible nats *)
  intros ae1 ae2 n1 n2 H_about_ae1 H_about_ae2.
  rewrite -> (unfold_evaluate_v0_plus ae1 ae2).
  rewrite -> H_about_ae1 ; rewrite -> H_about_ae2.
  reflexivity.

  (* Minus : error on arg 1 *)
  split.
  intros ae1 ae2 s1 H_about_ae1.
  (* use any value to instantiate the natural values in the unfold lemma *)
  rewrite -> (unfold_evaluate_v0_minus ae1 ae2).
  rewrite -> H_about_ae1.
  reflexivity.

  (* Minus : error on arg 2 *)
  split.
  intros ae1 ae2 n1 s2 H_about_ae1 H_about_ae2.
  rewrite -> (unfold_evaluate_v0_minus ae1 ae2).
  rewrite -> H_about_ae1 ; rewrite -> H_about_ae2.
  reflexivity.

  (* Minus : both args are expressible nats, but n1 < n2 (underflow *)
  split.
  (* note : we name the variables m1 and m2 to avoid clashed with the names in
   * the unfold lemma. Coq automatically modifies the variable names, but we
   * would rather be in control *)
  intros ae1 ae2 m1 m2 H_about_ae1 H_about_ae2 H_about_n1_and_n2.
  rewrite -> (unfold_evaluate_v0_minus ae1 ae2).
  rewrite -> H_about_ae1 ; rewrite -> H_about_ae2;
    rewrite -> H_about_n1_and_n2.
  reflexivity.

  (* Minus : both args are expressible nats, and there is no underflow *)
  intros ae1 ae2 n1 n2 H_about_ae1 H_about_ae2 H_about_n1_and_n2.
  rewrite -> (unfold_evaluate_v0_minus ae1 ae2).
  rewrite -> H_about_ae1 ; rewrite -> H_about_ae2 ;
    rewrite -> H_about_n1_and_n2.
  reflexivity.
Qed.

(* We have thus shown that the specification_of_evaluate is sound and complete, and
 * also defined a function that evaluates a given arithmetic_expression *)

Definition specification_of_interpret (interpret : source_program -> expressible_value) :=
  forall evaluate : arithmetic_expression -> expressible_value,
    specification_of_evaluate evaluate ->
    forall ae : arithmetic_expression,
      interpret (Source_program ae) = evaluate ae.

(* Theorem to prove soundness of the specification_of_interpret *)
Theorem specification_of_interpret_is_sound :
  forall (i1 i2 : source_program -> expressible_value),
    specification_of_interpret i1 ->
    specification_of_interpret i2 ->
    forall (ae : arithmetic_expression),
      i1 (Source_program ae) = i2 (Source_program ae).
Proof.
  intros i1 i2.
  unfold specification_of_interpret.
  intros H1 H2 ae.
  (* since evaluate_v0 is a function of type of arithmetic_expression ->
   * expressible_value, and it meets the specification_of_evaluate,
   * we may use it to instantiate the evaluate variable in the hypotheses *)
  rewrite -> (H1 evaluate_v0 evaluate_v0_meets_the_specification_of_evaluate ae).
  rewrite -> (H2 evaluate_v0 evaluate_v0_meets_the_specification_of_evaluate ae).
  reflexivity.
Qed.

(* implementation of interpret *)
Definition interpret_v0 (sp : source_program ) : expressible_value :=
  match sp with
  | Source_program ae =>
    evaluate_v0 ae
  end.

(* interpret_v0 meets the specification of interpret *)
Theorem interpret_v0_meets_the_specification_of_interpret :
  specification_of_interpret interpret_v0.
Proof.
  unfold specification_of_interpret.
  intros evaluate_var H_about_evaluate_var.
  intro ae.
  unfold interpret_v0.
  rewrite ->
          (specification_of_evaluate_is_sound
          evaluate_var
          evaluate_v0
          H_about_evaluate_var
          evaluate_v0_meets_the_specification_of_evaluate
          ae).
  reflexivity.
Qed.

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

(* Task 2 (if there is time):
   Define an interpreter with a function in continuation-passing style
   that satisfies the specification above,
   and that only apply the current continuation to the result of evaluating
   an expression if evaluating this expression did not yield an error.
*)

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

(* Byte-code instructions: *)

Inductive byte_code_instruction : Type :=
| PUSH : nat -> byte_code_instruction
| ADD : byte_code_instruction
| SUB : byte_code_instruction.

(* Target programs: *)

Inductive target_program : Type :=
| Target_program : list byte_code_instruction -> target_program.

(* Data stack: *)

Definition data_stack := list nat.

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

Inductive result_of_decoding_and_execution : Type :=
| OK : data_stack -> result_of_decoding_and_execution
| KO : string -> result_of_decoding_and_execution.

Definition specification_of_decode_execute (decode_execute : byte_code_instruction -> data_stack -> result_of_decoding_and_execution) :=
  (* pushing natural value onto the data stack (or the operation stack) *)
  (forall (n : nat)
          (ds : data_stack),
     decode_execute (PUSH n) ds = OK (n :: ds))
  /\
  (* pushing an ADD instruction onto the stack; only if the stack has at least two
   * natural values can the addition be performed *)
  ((decode_execute ADD nil = KO "ADD: stack underflow")
   /\
   (forall (n2 : nat),
       decode_execute ADD (n2 :: nil) = KO "ADD: stack underflow")
   /\
   (forall (n1 n2 : nat)
           (ds : data_stack),
       decode_execute ADD (n2 :: n1 :: ds) = OK ((n1 + n2) :: ds)))
  /\
  (* likewise for the SUB instruction *)
  ((decode_execute SUB nil = KO "SUB: stack underflow")
   /\
   (forall (n2 : nat),
       decode_execute SUB (n2 :: nil) = KO "SUB: stack underflow")
   /\
   (forall (n1 n2 : nat)
           (ds : data_stack),
       ltb n1 n2 = true ->
       decode_execute SUB (n2 :: n1 :: ds) = KO "numerical underflow")
   /\
   (forall (n1 n2 : nat)
           (ds : data_stack),
       ltb n1 n2 = false ->
       decode_execute SUB (n2 :: n1 :: ds) = OK ((n1 - n2) :: ds))).

(* Task 3:
   prove that the definition above specifies a unique function,
   implement this function,
   and verify that your function satisfies the specification.
 *)

(* proving that specification_of_decode_execute is sound *)
Theorem specification_of_decode_execute_is_sound :
  forall (de1 de2 : byte_code_instruction -> data_stack ->
                    result_of_decoding_and_execution),
    specification_of_decode_execute de1 ->
    specification_of_decode_execute de2 ->
    forall (bcis : byte_code_instruction) (ds :data_stack),
      de1 bcis ds = de2 bcis ds.
Proof.
  intros de1 de2.
  unfold specification_of_decode_execute.
  intros [de1_push [[de1_add_err1 [de1_add_err2 de1_add_eval]]
                      [de1_sub_err1 [de1_sub_err2 [de1_sub_err_ufl de1_sub_eval]]]]]
         [de2_push [[de2_add_err1 [de2_add_err2 de2_add_eval]]
                      [de2_sub_err1 [de2_sub_err2 [de2_sub_err_ufl de2_sub_eval]]]]].
  intros bcis ds.

  (* we now consider all possible bcis on a case by case basis *)
  case bcis as [ n'| | ].

  (* PUSH *)
  rewrite -> (de1_push n' ds); rewrite -> (de2_push n' ds); reflexivity.

  (* ADD *)
  (* now consider different cases of ds *)
  case ds as [ | n' ds'].

  (* case 1: ds is NIL, stack underflow *)
  rewrite -> de1_add_err1 ; rewrite -> de2_add_err1; reflexivity.

  (* case 2: ds is of the form n'::ds' ; we now consider two case for ds';
   * when ds' is NIL, we still have a stack underflow *)
  case ds' as [ |n'' ds''].
  rewrite -> (de1_add_err2 n'); rewrite -> (de2_add_err2 n'); reflexivity.

  (* case 3 : ds is of the form n' :: (n'' :: ds'') *)
  rewrite -> (de1_add_eval n'' n' ds''); rewrite -> (de2_add_eval n'' n' ds'');
    reflexivity.

  (* SUB *)
  (* now consider different cases of ds *)
  case ds as [ | n' ds'].

  (* case 1: ds is NIL, stack underflow *)
  rewrite -> de1_sub_err1 ; rewrite -> de2_sub_err1; reflexivity.

  (* case 2: ds is of the form n'::ds' ; we now consider two case for ds';
   * when ds' is NIL, we still have a stack underflow *)
  case ds' as [ |n'' ds''].
  rewrite -> (de1_sub_err2 n'); rewrite -> (de2_sub_err2 n'); reflexivity.

  (* case 3: ds is of the form n'::n''::ds'' ; now we consider cases of numerical
   * underflow *)
  case (ltb n'' n') as [ | ] eqn : val_of_ltb_n''_n'.
  rewrite -> (de1_sub_err_ufl n'' n' ds'' val_of_ltb_n''_n');
    rewrite -> (de2_sub_err_ufl n'' n' ds'' val_of_ltb_n''_n');
    reflexivity.

  (* case 4: no numerical underflow *)
  rewrite -> (de1_sub_eval n'' n' ds'' val_of_ltb_n''_n');
    rewrite -> (de2_sub_eval n'' n' ds'' val_of_ltb_n''_n');
    reflexivity.
Qed.

Definition decode_execute (bcis : byte_code_instruction) (ds : data_stack) : result_of_decoding_and_execution :=
  match bcis with
  | PUSH n =>
  OK (n::ds)
  | ADD =>
    match ds with
    | nil =>
      KO "ADD: stack underflow"
    | n':: nil =>
      KO "ADD: stack underflow"
    | n2 :: n1 :: ds'' =>
      OK ( (n1 + n2) :: ds'' )
    end
  |SUB =>
    match ds with
    | nil =>
      KO "SUB: stack underflow"
    | n':: nil =>
      KO "SUB: stack underflow"
    | n2 :: n1 :: ds'' =>
      if (ltb n1 n2)
      then KO "numerical underflow"
      else OK ( (n1 - n2) :: ds'' )
    end
  end.

(* the implementtation of decode_execute satisfies the specification 8*)
Theorem decode_execute_satisfies_the_specification_of_decode_execute :
  specification_of_decode_execute decode_execute.
Proof.
  unfold specification_of_decode_execute.

  (* PUSH *)
  split.
  intros n ds.
  unfold decode_execute.
  reflexivity.

  (* ADD *)
  split.
  split.
  unfold decode_execute.
  reflexivity.

  split.
  intro n2.
  unfold decode_execute.
  reflexivity.

  intros n1 n2 ds.
  unfold decode_execute.
  reflexivity.

  (* SUB *)
  split.
  unfold decode_execute.
  reflexivity.

  split.
  intro n2.
  unfold decode_execute.
  reflexivity.

  (* killing two birds with one do *)
  do 2 (split;
  intros n1 n2 ds H_about_n1_and_n2;
  unfold decode_execute;
  rewrite -> H_about_n1_and_n2;
  reflexivity).
Qed.

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

(* Specification of the virtual machine: *)

Definition specification_of_fetch_decode_execute_loop (fetch_decode_execute_loop : list byte_code_instruction -> data_stack -> result_of_decoding_and_execution) :=
  forall decode_execute : byte_code_instruction -> data_stack -> result_of_decoding_and_execution,
    specification_of_decode_execute decode_execute ->
    (forall ds : data_stack,
        fetch_decode_execute_loop nil ds = OK ds)
    /\
    (forall (bci : byte_code_instruction)
            (bcis' : list byte_code_instruction)
            (ds ds' : data_stack),
        decode_execute bci ds = OK ds' ->
        fetch_decode_execute_loop (bci :: bcis') ds =
        fetch_decode_execute_loop bcis' ds')
    /\
    (forall (bci : byte_code_instruction)
            (bcis' : list byte_code_instruction)
            (ds : data_stack)
            (s : string),
        decode_execute bci ds = KO s ->
        fetch_decode_execute_loop (bci :: bcis') ds =
        KO s).

(* Task 4:
   prove that the definition above specifies a unique function,
   implement this function,
   and verify that your function satisfies the specification.
 *)

(* specification_of_fetch_decode_execute_loop is sound *)
Theorem specification_of_fetch_decode_execute_loop_is_sound :
  forall (fdel1 fdel2 : list byte_code_instruction -> data_stack ->
                        result_of_decoding_and_execution),
    specification_of_fetch_decode_execute_loop fdel1 ->
    specification_of_fetch_decode_execute_loop fdel2 ->
    forall (bcis : list byte_code_instruction)
           (ds : data_stack),
      fdel1 bcis ds = fdel2 bcis ds.
Proof.
  intros fdel1 fdel2.
  unfold specification_of_fetch_decode_execute_loop.
  (* to obtain the hypotheses for the conjunctive branches of the specificaiton,
   * we must use destruct *)
  intros H1 H2.
  destruct  (H1 decode_execute
            decode_execute_satisfies_the_specification_of_decode_execute) as
      [fdel1_completion [fdel1_execution fdel1_error]].
  destruct  (H2 decode_execute
                decode_execute_satisfies_the_specification_of_decode_execute) as
      [fdel2_completion [fdel2_execution fdel2_error]].
  (* don't introduce ds, we will use this parameterize our induction proof *)
  intros bcis.
  (* induct over the list of byte code instructions *)
  induction bcis as [ | i' i's IH_i'].

  (* case 1: the bci list is empty *)
  intro ds.
  rewrite -> (fdel1_completion ds).
  rewrite -> (fdel2_completion ds).
  reflexivity.

  (* case 2: the bci list is of the form bci'::bcis';  we must now consider
   * the evaluation of the bci at the head of the list ; first condier the
   * situation where it evaluates to OK (ds) *)
  intro ds.
  case (decode_execute i' ds) as [new_ds | error_string]
                                   eqn : decode_execute_value_for_i'.
  rewrite -> (fdel1_execution i' i's ds new_ds decode_execute_value_for_i').
  rewrite -> (fdel2_execution i' i's ds new_ds decode_execute_value_for_i').
  rewrite -> (IH_i' new_ds).
  reflexivity.

  (* case 3: the bci' evaluates to KO (s) *)
  rewrite -> (fdel1_error i' i's ds error_string decode_execute_value_for_i').
  rewrite -> (fdel2_error i' i's ds error_string decode_execute_value_for_i').
  reflexivity.
Qed.

(* implementation of the specification_of_fetch_decode_execute_loop *)
Fixpoint fetch_decode_execute_loop
         (insts : list byte_code_instruction)
         (ds : data_stack) : result_of_decoding_and_execution :=
  match insts with
  | nil =>
    OK ds
  | inst :: inst' =>
    match (decode_execute inst ds) with
    | OK new_ds =>
      fetch_decode_execute_loop inst' new_ds
    | KO s =>
      KO s
    end
  end.

(* Standard unfold lemmas *)
Lemma unfold_fetch_decode_execute_loop_nil :
  forall (ds : data_stack),
    fetch_decode_execute_loop nil ds = OK ds.
Proof.
  unfold_tactic fetch_decode_execute_loop.
Qed.

Lemma unfold_fetch_decode_execute_loop_bcis :
  forall (inst : byte_code_instruction)
         (inst' : list byte_code_instruction)
         (ds : data_stack),
    fetch_decode_execute_loop (inst :: inst') ds =
    match (decode_execute inst ds) with
    | OK new_ds =>
      fetch_decode_execute_loop inst' new_ds
    | KO s =>
      KO s
     end.
Proof.
  unfold_tactic fetch_decode_execute_loop.
Qed.

(* Now we prove that the implementation of fetch_decode_execute_loop satifies the
 * specification *)
Theorem fetch_decode_execute_loop_satisfies_the_specification :
  specification_of_fetch_decode_execute_loop fetch_decode_execute_loop.
Proof.
  unfold specification_of_fetch_decode_execute_loop.
  intros decode_execute_var H_about_decode_execute_var.

  (* nil case *)
  split.
  intro ds.
  exact (unfold_fetch_decode_execute_loop_nil ds).

  (* cons case with continued execution *)
  split.
  intros bci bcis' ds ds' H_about_decode_execute_bci.
  rewrite -> (unfold_fetch_decode_execute_loop_bcis
                bci bcis' ds).
  (* use the soundness of the specification_of_decode_execute to replace
   * decode_execute_var with decode_execute *)
  rewrite ->
          (specification_of_decode_execute_is_sound
             decode_execute_var
             decode_execute
             H_about_decode_execute_var
             decode_execute_satisfies_the_specification_of_decode_execute
             bci ds) in H_about_decode_execute_bci.
  rewrite -> H_about_decode_execute_bci.
  reflexivity.

  (* cons case with error *)
  intros bci bcis' ds s H_about_decode_execute_bci.
  rewrite ->
          (specification_of_decode_execute_is_sound
             decode_execute_var
             decode_execute
             H_about_decode_execute_var
             decode_execute_satisfies_the_specification_of_decode_execute
             bci ds) in H_about_decode_execute_bci.
  (* note: we will not be needing the new_ds variable; thus we may pass any
   * value of the type list nat. *)
  rewrite -> (unfold_fetch_decode_execute_loop_bcis
                bci bcis' ds).
  rewrite -> H_about_decode_execute_bci.
reflexivity.
Qed.

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

Lemma unfold_append_nil :
  forall bcis2 : list byte_code_instruction,
    nil ++ bcis2 = bcis2.
Proof.
  unfold_tactic List.app.
Qed.

Lemma unfold_append_cons :
  forall (bci1 : byte_code_instruction)
         (bci1s bci2s : list byte_code_instruction),
    (bci1 :: bci1s) ++ bci2s =
    bci1 :: (bci1s ++ bci2s).
Proof.
  unfold_tactic List.app.
Qed.

(* Task 5:
   Prove that for any lists of byte-code instructions bcis1 and bcis2,
   and for any data stack ds,
   executing the concatenation of bcis1 and bcis2 (i.e., bcis1 ++ bcis2) with ds
   gives the same result as
   (1) executing bcis1 with ds, and then
   (2) executing bcis2 with the resulting data stack, if there exists one.
*)

Theorem relation_between_execution_of_two_bcis_and_their_appended_version :
  forall (bci1s bci2s : list byte_code_instruction),
    (forall (ds : data_stack)
            (ds_new : data_stack),
        fetch_decode_execute_loop bci1s ds = OK ds_new ->
        fetch_decode_execute_loop (bci1s ++ bci2s) ds =
        fetch_decode_execute_loop (bci2s) ds_new) /\
    (forall (ds : data_stack) (s : string),
        fetch_decode_execute_loop bci1s ds = KO s ->
        fetch_decode_execute_loop (bci1s ++ bci2s) ds = KO s).
Proof.
  intros bci1s bci2s.

  (* consider the first conjunctive clause *)
  split.
  induction bci1s as [ | i' is' IH_is'].

  (* base case *)
  intros ds ds_new H_when_bcis_is_nil.
  rewrite -> unfold_append_nil.
  rewrite -> (unfold_fetch_decode_execute_loop_nil) in H_when_bcis_is_nil.
  injection H_when_bcis_is_nil as H_about_ds_and_ds_new.
  rewrite -> H_about_ds_and_ds_new.
  reflexivity.

  (* inductive case *)
  intros ds ds_new H_when_bcis_is_cons.
  rewrite -> unfold_append_cons.
  case (decode_execute i' ds) as [ ds_after_de_i' | s] eqn : value_of_de_i'.
  (* rewrite the goal for when (decode_execute i') = OK _ *)
  rewrite -> (unfold_fetch_decode_execute_loop_bcis i' (is' ++ bci2s) ds).
  rewrite -> value_of_de_i'.
  (* rewrite H_when_bcis_is_cons *)
  rewrite -> (unfold_fetch_decode_execute_loop_bcis i' is' ds) in H_when_bcis_is_cons.
  rewrite -> value_of_de_i' in H_when_bcis_is_cons.
  Check (IH_is' ds_after_de_i' ds_new).
  apply (IH_is' ds_after_de_i' ds_new) in H_when_bcis_is_cons.
  rewrite -> H_when_bcis_is_cons.
  reflexivity.

  (* now consider the case where (decode_execute i') = KO _; clearly this gives
   * rise to an absurd situation, so we use the discriminate tactic *)
  rewrite ->  (unfold_fetch_decode_execute_loop_bcis i' is' ds)
                                                    in H_when_bcis_is_cons.
  rewrite -> value_of_de_i' in H_when_bcis_is_cons.
  discriminate.

  (* consider the second conjunctive clause *)
  induction bci1s as [ | i' is'  IH_is'].
  intros ds s H_about_bcis_nil.

  (* base case *)
  rewrite -> unfold_fetch_decode_execute_loop_nil in H_about_bcis_nil.
  discriminate.

  (* inductive case *)
  intros ds s H_about_bcis_cons.
  rewrite -> unfold_append_cons.
  (* once again, consider the cases of decode_execute i' *)
  case (decode_execute i' ds) as [ds_returned | error_msg] eqn : value_of_de_i'.

  (* case 1: decode_execute i' = OK _ *)
  (* modify H_about_bcis_cons *)
  rewrite -> (unfold_fetch_decode_execute_loop_bcis i' is' ds)
                                                    in H_about_bcis_cons.
  rewrite -> value_of_de_i' in H_about_bcis_cons.
  apply (IH_is' ds_returned s) in H_about_bcis_cons.
  rewrite <- H_about_bcis_cons.
  (* modify the goal *)
  rewrite ->
          (unfold_fetch_decode_execute_loop_bcis i' (is' ++ bci2s) ds).
  rewrite -> value_of_de_i'.
  reflexivity.

  (* case 2: decode_execute i' = KO _ *)
  (* modify H_about_bcis_cons *)
  rewrite -> (unfold_fetch_decode_execute_loop_bcis i' is' ds)
    in H_about_bcis_cons.
  rewrite -> value_of_de_i' in H_about_bcis_cons.
  (* modify the goal *)
  rewrite -> (unfold_fetch_decode_execute_loop_bcis i' (is' ++ bci2s) ds).
  rewrite -> value_of_de_i'.
  exact H_about_bcis_cons.
  (* note : since the loop stops executing the remaining instructions in bci1s as soon
   * as an error message is encountered, we did not need the induction hypothesis *)
Qed.

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

Definition specification_of_run (run : target_program -> expressible_value) :=
  forall fetch_decode_execute_loop : list byte_code_instruction -> data_stack -> result_of_decoding_and_execution,
    specification_of_fetch_decode_execute_loop fetch_decode_execute_loop ->
    (forall (bcis : list byte_code_instruction),
       fetch_decode_execute_loop bcis nil = OK nil ->
       run (Target_program bcis) = Expressible_msg "no result on the data stack")
    /\
    (forall (bcis : list byte_code_instruction)
            (n : nat),
       fetch_decode_execute_loop bcis nil = OK (n :: nil) ->
       run (Target_program bcis) = Expressible_nat n)
    /\
    (forall (bcis : list byte_code_instruction)
            (n n' : nat)
            (ds'' : data_stack),
       fetch_decode_execute_loop bcis nil = OK (n :: n' :: ds'') ->
       run (Target_program bcis) = Expressible_msg "too many results on the data stack")
    /\
    (forall (bcis : list byte_code_instruction)
            (s : string),
       fetch_decode_execute_loop bcis nil = KO s ->
       run (Target_program bcis) = Expressible_msg s).

(* Task 6:
   prove that the definition above specifies a unique function,
   implement this function,
   and verify that your function satisfies the specification.
 *)

(* the specification_of_run is sound *)
Theorem specification_of_run_is_sound :
  forall (run1 run2 : target_program -> expressible_value),
    specification_of_run run1 ->
    specification_of_run run2 ->
    forall (bcis : list byte_code_instruction),
      run1 (Target_program bcis) = run2 (Target_program bcis).
Proof.
  intros run1 run2.
  unfold specification_of_run.
  intros H1 H2.
  destruct (H1 fetch_decode_execute_loop
               fetch_decode_execute_loop_satisfies_the_specification)
    as [ run1_no_result [run1_one_result [run1_too_many_results
                                             run1_error_message ]]].
  destruct (H2 fetch_decode_execute_loop
               fetch_decode_execute_loop_satisfies_the_specification)
    as [ run2_no_result [run2_one_result [run2_too_many_results
                                             run2_error_message ]]].
  intro bcis.
  (* now consider the multiple cases of applying the fetch_decode_execute_loop to
   * bcis and nil *)
  case (fetch_decode_execute_loop bcis nil) as [ return_ds | runtime_error_msg]
                                                 eqn : value_of_bcis_execution.
  (* for the case where a data stack is returned, consider the 3 cases of no results,
   * one result, and too many results *)
  case return_ds as [ | d1 [ | d2 ds']] eqn : value_of_return_ds.

  (* case 1: no result on stack *)
  rewrite -> (run1_no_result bcis value_of_bcis_execution);
    rewrite -> (run2_no_result bcis value_of_bcis_execution);
    reflexivity.

  (* case 2: one result on stack *)
  rewrite -> (run1_one_result bcis d1 value_of_bcis_execution);
    rewrite -> (run2_one_result bcis d1 value_of_bcis_execution);
    reflexivity.

  (* case 3 : too many results on stack *)
  rewrite -> (run1_too_many_results bcis d1 d2 ds' value_of_bcis_execution);
    rewrite -> (run2_too_many_results bcis d1 d2 ds' value_of_bcis_execution);
    reflexivity.

  (* case 4 : run time error *)
  rewrite -> (run1_error_message bcis runtime_error_msg value_of_bcis_execution);
  rewrite -> (run2_error_message bcis runtime_error_msg value_of_bcis_execution);
  reflexivity.
Qed.

(* Implementation of the specification_of_run *)

Definition run (prog : target_program) : expressible_value :=
  match prog with
  |Target_program bcis =>
   match (fetch_decode_execute_loop bcis nil) with
   | OK nil =>
     Expressible_msg "no result on the data stack"
   | OK (n :: nil) =>
     Expressible_nat n
   | OK (n :: n' :: ds) =>
     Expressible_msg "too many results on the data stack"
   | KO error_msg =>
     Expressible_msg error_msg
   end
  end.

(* proof that this implementation satisfies the given specification *)
Theorem run_satisfies_the_specification_of_run :
  specification_of_run run.
Proof.
  unfold specification_of_run.
  intros fetch_decode_execute_loop_var H_about_fetch_decode_execute_loop_var.

  split.
  intros bcis H_about_evaluation_of_bcis.
  (* we would like to replace fetch_decode_execute_loop_var with
   * fetch_decode_execute_loop, since run uses this function *)
  rewrite ->
          (specification_of_fetch_decode_execute_loop_is_sound
          fetch_decode_execute_loop_var
          fetch_decode_execute_loop
          H_about_fetch_decode_execute_loop_var
          fetch_decode_execute_loop_satisfies_the_specification
          bcis nil) in H_about_evaluation_of_bcis.
  unfold run.
  rewrite -> H_about_evaluation_of_bcis.
  reflexivity.

  (* the proofs for the remaining three cases is similar to the case above ;
   * the only different is in the values that require to be introed *)
  split.
  intros bcis n H_about_evaluation_of_bcis.
  rewrite ->
          (specification_of_fetch_decode_execute_loop_is_sound
          fetch_decode_execute_loop_var
          fetch_decode_execute_loop
          H_about_fetch_decode_execute_loop_var
          fetch_decode_execute_loop_satisfies_the_specification
          bcis nil) in H_about_evaluation_of_bcis.
  unfold run.
  rewrite -> H_about_evaluation_of_bcis.
  reflexivity.

  split.
  intros bcis n n' ds'' H_about_evaluation_of_bcis.
  rewrite ->
          (specification_of_fetch_decode_execute_loop_is_sound
          fetch_decode_execute_loop_var
          fetch_decode_execute_loop
          H_about_fetch_decode_execute_loop_var
          fetch_decode_execute_loop_satisfies_the_specification
          bcis nil) in H_about_evaluation_of_bcis.
  unfold run.
  rewrite -> H_about_evaluation_of_bcis.
  reflexivity.

  intros bcis s H_about_evaluation_of_bcis.
  unfold run.
  rewrite ->
          (specification_of_fetch_decode_execute_loop_is_sound
          fetch_decode_execute_loop_var
          fetch_decode_execute_loop
          H_about_fetch_decode_execute_loop_var
          fetch_decode_execute_loop_satisfies_the_specification
          bcis nil) in H_about_evaluation_of_bcis.
  rewrite -> H_about_evaluation_of_bcis.
  reflexivity.
Qed.

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

Definition specification_of_compile_aux (compile_aux : arithmetic_expression -> list byte_code_instruction) :=
  (forall n : nat,
     compile_aux (Literal n) = PUSH n :: nil)
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile_aux (Plus ae1 ae2) = (compile_aux ae1) ++ (compile_aux ae2) ++ (ADD :: nil))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile_aux (Minus ae1 ae2) = (compile_aux ae1) ++ (compile_aux ae2) ++ (SUB :: nil)).

(* Task 6:
   prove that the definition above specifies a unique function,
   implement this function using list concatenation, i.e., ++,
   and verify that your function satisfies the specification.
 *)

(* the specification_of_compile_aux is sound *)
Theorem specification_of_compile_aux_is_sound :
  forall (compile_aux_1 compile_aux_2 : arithmetic_expression ->
                                        list byte_code_instruction),
    specification_of_compile_aux compile_aux_1 ->
    specification_of_compile_aux compile_aux_2 ->
    forall (ae : arithmetic_expression),
      compile_aux_1 ae = compile_aux_2 ae.
Proof.
  intros compile_aux_1 compile_aux_2.
  unfold specification_of_compile_aux.
  intros [compile_aux_1_push [compile_aux_1_add compile_aux_1_sub]]
         [compile_aux_2_push [compile_aux_2_add compile_aux_2_sub]].
  intro ae.
  (* now consider and induction over ae *)
  induction ae as [ n | exp1 IH_exp1_add exp2 IH_exp2_add
                    | exp1 IH_exp1_sub exp2 IH_exp2_sub].

  (* case 1 : Literal *)
  rewrite -> (compile_aux_1_push n) ; rewrite -> (compile_aux_2_push n) ;
    reflexivity.

  (* case 2 : Addition of expressions *)
  rewrite -> (compile_aux_1_add exp1 exp2); rewrite -> (compile_aux_2_add exp1 exp2).
  rewrite -> IH_exp1_add; rewrite -> IH_exp2_add.
  reflexivity.

  (* case 3: subtraction of expressions *)
  rewrite -> (compile_aux_1_sub exp1 exp2); rewrite -> (compile_aux_2_sub exp1 exp2).
  rewrite -> IH_exp1_sub; rewrite -> IH_exp2_sub.
  reflexivity.
Qed.

(* implementation of compilation using concatenation of bci lists *)
Fixpoint compile_aux_v0 (ae : arithmetic_expression) : list byte_code_instruction :=
  match ae with
  | Literal n =>
    (PUSH n) :: nil
  | Plus ae1 ae2 =>
    (compile_aux_v0 ae1) ++ (compile_aux_v0 ae2) ++ (ADD :: nil)
  | Minus ae1 ae2 =>
    (compile_aux_v0 ae1) ++ (compile_aux_v0 ae2) ++ (SUB :: nil)
  end.

(* standard unfold lemmas *)
Lemma unfold_compile_aux_v0_literal :
  forall (n : nat),
    compile_aux_v0 (Literal n) = (PUSH n) :: nil.
Proof.
  unfold_tactic compile_aux_v0.
Qed.

Lemma unfold_compile_aux_v0_plus :
  forall (ae1 ae2 : arithmetic_expression),
    compile_aux_v0 (Plus ae1 ae2)  =
    (compile_aux_v0 ae1) ++ (compile_aux_v0 ae2) ++ (ADD :: nil).
Proof.
  unfold_tactic compile_aux_v0.
Qed.

Lemma unfold_compile_aux_v0_minus :
  forall (ae1 ae2 : arithmetic_expression),
    compile_aux_v0 (Minus ae1 ae2)  =
    (compile_aux_v0 ae1) ++ (compile_aux_v0 ae2) ++ (SUB :: nil).
Proof.
  unfold_tactic compile_aux_v0.
Qed.

(* proof that compile_aux_v0 meets the specification *)
Theorem compile_aux_v0_meets_specification_of_compile_aux :
  specification_of_compile_aux compile_aux_v0.
Proof.
  unfold specification_of_compile_aux.

  split.
  intro n.
  rewrite -> (unfold_compile_aux_v0_literal n).
  reflexivity.

  split.
  intros ae1 ae2.
  rewrite -> (unfold_compile_aux_v0_plus ae1 ae2).
  reflexivity.

  intros ae1 ae2.
  rewrite -> (unfold_compile_aux_v0_minus ae1 ae2).
  reflexivity.
Qed.

Definition specification_of_compile (compile : source_program -> target_program) :=
  forall compile_aux : arithmetic_expression -> list byte_code_instruction,
    specification_of_compile_aux compile_aux ->
    forall ae : arithmetic_expression,
      compile (Source_program ae) = Target_program (compile_aux ae).

(* Task 7:
   prove that the definition above specifies a unique function,
   implement this function,
   and verify that your function satisfies the specification.
 *)
(* the specification_of_compile is sound *)
Theorem specification_of_compile_is_sound :
  forall (compiler1 compiler2 : source_program -> target_program),
    specification_of_compile compiler1 ->
    specification_of_compile compiler2 ->
    forall (ae : arithmetic_expression),
      compiler1 (Source_program ae) =
      compiler2 (Source_program ae).
Proof.
  intros compiler1 compiler2.
  unfold specification_of_compile.
  intros H1 H2.
  intro ae.
  rewrite -> (H1 compile_aux_v0 compile_aux_v0_meets_specification_of_compile_aux ae).
  rewrite -> (H2 compile_aux_v0 compile_aux_v0_meets_specification_of_compile_aux ae).
  reflexivity.
Qed.

(* implementation of the specification_of_compile *)
Definition compile_v0 (sp : source_program) : target_program :=
  match sp with
  | Source_program sp =>
    Target_program (compile_aux_v0 sp)
  end.

(* Proof that compile_v0 meets the specification_of_compile *)
Theorem compile_v0_meets_the_specification_of_compile :
  specification_of_compile compile_v0.
Proof.
  unfold specification_of_compile.
  intros compile_aux_var H_about_compile_aux_var.
  intro ae.
  unfold compile_v0.
  rewrite ->
          (specification_of_compile_aux_is_sound
          compile_aux_var
          compile_aux_v0
          H_about_compile_aux_var
          compile_aux_v0_meets_specification_of_compile_aux
          ae).
  reflexivity.
Qed.

(* Task 8:
   implement an alternative compiler
   using an auxiliary function with an accumulator
   and that does not use ++ but :: instead,
   and prove that it satisfies the specification.
 *)

(* auxiliary compile function implemented with accumulator *)
Fixpoint compile_aux_v1 (ae : arithmetic_expression)
         (acc : list byte_code_instruction) : list byte_code_instruction :=
  match ae with
  | Literal n =>
    (PUSH n) :: acc
  | Plus ae1 ae2 =>
    compile_aux_v1 ae1 (compile_aux_v1 ae2 (ADD :: acc))
  | Minus ae1 ae2 =>
    compile_aux_v1 ae1 (compile_aux_v1 ae2 (SUB :: acc))
  end.

(* unfold lemmas *)
Lemma unfold_compile_aux_v1_literal :
  forall (n : nat)
         (acc : list byte_code_instruction),
    compile_aux_v1 (Literal n) acc = (PUSH n) :: acc.
Proof.
  unfold_tactic compile_aux_v1.
Qed.

Lemma unfold_compile_aux_v1_plus :
  forall (ae1 ae2 : arithmetic_expression)
         (acc :list byte_code_instruction),
    compile_aux_v1 (Plus ae1 ae2) acc =
    compile_aux_v1 ae1 (compile_aux_v1 ae2 (ADD :: acc)).
Proof.
  unfold_tactic compile_aux_v1.
Qed.

Lemma unfold_compile_aux_v1_minus :
  forall (ae1 ae2 : arithmetic_expression)
         (acc :list byte_code_instruction),
    compile_aux_v1 (Minus ae1 ae2) acc =
    compile_aux_v1 ae1 (compile_aux_v1 ae2 (SUB :: acc)).
Proof.
  unfold_tactic compile_aux_v1.
Qed.

(* Master lemma concerning the relation between compile_aux_v1 and compile_aux_v0 *)
Lemma master_lemma_about_compile_aux_v1 :
  forall (ae : arithmetic_expression)
         (acc : list byte_code_instruction),
    compile_aux_v1 ae acc =  (compile_aux_v0 ae) ++ acc.
Proof.
  intros ae.
  induction ae as [ n | exp1 IH_exp1_add exp2 IH_exp2_add |
                    exp1 IH_exp1_sub exp2 IH_exp2_sub ].

  (* literals *)
  intro acc.
  rewrite -> (unfold_compile_aux_v1_literal n acc).
  rewrite -> (unfold_compile_aux_v0_literal n).
  Search (_ ++ _ = _).
  rewrite -> (unfold_append_cons (PUSH n) nil acc).
  rewrite -> (unfold_append_nil).
  reflexivity.

  (* plus *)
  intro acc.
  rewrite -> (unfold_compile_aux_v1_plus exp1 exp2 acc).
  rewrite -> (unfold_compile_aux_v0_plus exp1 exp2).
  rewrite -> (IH_exp2_add (ADD :: acc)).
  rewrite -> (IH_exp1_add (compile_aux_v0 exp2 ++ ADD :: acc)).
  Search (_ ++ _ = _).
  rewrite -> app_assoc_reverse.
  rewrite -> app_assoc_reverse.
  rewrite -> unfold_append_cons.
  rewrite -> unfold_append_nil.
  reflexivity.

  (* the proof for minus will be very similar *)
  intro acc.
  rewrite -> (unfold_compile_aux_v1_minus exp1 exp2 acc).
  rewrite -> (unfold_compile_aux_v0_minus exp1 exp2).
  rewrite -> (IH_exp2_sub (SUB :: acc)).
  rewrite -> (IH_exp1_sub (compile_aux_v0 exp2 ++ SUB :: acc)).
  Search (_ ++ _ = _).
  rewrite -> app_assoc_reverse.
  rewrite -> app_assoc_reverse.
  rewrite -> unfold_append_cons.
  rewrite -> unfold_append_nil.
  reflexivity.
Qed.

(* compiler implementation that uses an accumulator based auxiliary function *)
Definition compile_v1 (sp : source_program) : target_program :=
  match sp with
  | Source_program sp =>
    Target_program (compile_aux_v1 sp nil)
  end.

(* Proof that compile_v1 meets the specification_of_compile *)
Theorem compile_v1_meets_the_specification_of_compile :
  specification_of_compile compile_v1.
Proof.
  unfold specification_of_compile.
  intros compile_aux_var H_about_compile_aux_var.
  intro ae.
  unfold compile_v1.
  rewrite -> (master_lemma_about_compile_aux_v1 ae nil).
  Search ( _ ++ _ = _).
  rewrite -> app_nil_r.
  rewrite ->
          (specification_of_compile_aux_is_sound
          compile_aux_var
          compile_aux_v0
          H_about_compile_aux_var
          compile_aux_v0_meets_specification_of_compile_aux
          ae).
  reflexivity.
Qed.

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

(* Task 9 (the capstone):
   Prove that interpreting an arithmetic expression gives the same result
   as first compiling it and then executing the compiled program.
 *)

Lemma master_lemma_for_commutative_diagram :
  forall (ae : arithmetic_expression)
         (ds : data_stack),
      fetch_decode_execute_loop (compile_aux_v0 ae) ds =
      match (evaluate_v0 ae) with
      | Expressible_nat num =>
       OK (num :: ds)
      | Expressible_msg err_msg =>
        KO err_msg
      end.
Proof.
  (* we will prove this lemma by induction over arithmetic expressions *)
  induction ae as [ nat_val | e1 IH_e1_plus e2 IH_e2_plus |
                    e1 IH_e1_minus e2 IH_e2_minus].

  (* literals *)
  intro ds_for_lemma.
  (* unfold L.H.S. *)
  rewrite -> unfold_compile_aux_v0_literal.
  rewrite ->
          (unfold_fetch_decode_execute_loop_bcis (PUSH nat_val) nil ds_for_lemma).
  unfold decode_execute.
  rewrite -> unfold_fetch_decode_execute_loop_nil.
  (* unfold R.H.S. *)
  rewrite -> unfold_evaluate_v0_literal.
  reflexivity.

  (* plus expressions *)
  intro ds_for_lemma.
  (* unfold R.H.S and L.H.S. expressions *)
  rewrite -> (unfold_evaluate_v0_plus e1 e2).
  rewrite -> (unfold_compile_aux_v0_plus e1 e2).
  (* consider cases of evaluate_v0 first *)
  case (evaluate_v0 e1) as [err_msg_e1 | nat_val_e1] eqn : val_of_eval_v0_e1.

  (* evaluate_v0 e1 = Expressible_msg _ *)
  (* introduce lemma we proved about running the append of two bci lists *)
  Check (relation_between_execution_of_two_bcis_and_their_appended_version).
  destruct (relation_between_execution_of_two_bcis_and_their_appended_version
              (compile_aux_v0 e1)
              (compile_aux_v0 e2 ++ ADD :: nil)) as [H_OK H_KO].
  (* use the introduced hypotheses to modify the induction hypotheses, and use this
   * to prove the goal *)
  apply (H_KO ds_for_lemma err_msg_e1) in IH_e1_plus.
  rewrite -> IH_e1_plus.
  reflexivity.

  (* evaluate_v0 e1 = Expressible_nat _ *)
  (* once again, introduce this hypothesis *)
  destruct (relation_between_execution_of_two_bcis_and_their_appended_version
              (compile_aux_v0 e1)
              (compile_aux_v0 e2 ++ ADD :: nil)) as [H_OK H_KO].
  apply (H_OK ds_for_lemma (nat_val_e1 :: ds_for_lemma)) in IH_e1_plus.
  rewrite -> IH_e1_plus.
  clear H_OK H_KO.
  (* now consider cases of (evaluate_v0 e2) *)
  case (evaluate_v0 e2) as [err_msg_e2 | nat_val_e2] eqn : val_of_eval_v0_e2.

  (* evaluate_v0 e2 = Expressible_msg _ *)
  destruct (relation_between_execution_of_two_bcis_and_their_appended_version
              (compile_aux_v0 e2)
              (ADD :: nil)) as [H_OK H_KO].
  apply (H_KO (nat_val_e1 :: ds_for_lemma) err_msg_e2) in IH_e2_plus.
  rewrite -> IH_e2_plus.
  reflexivity.

  (* evaluate_v0 e2 = Expressible_msg _ *)
  destruct (relation_between_execution_of_two_bcis_and_their_appended_version
              (compile_aux_v0 e2)
              (ADD :: nil)) as [H_OK H_KO].
   apply (H_OK (nat_val_e1 :: ds_for_lemma)
              (nat_val_e2 :: nat_val_e1 :: ds_for_lemma)) in
            IH_e2_plus.
   rewrite -> IH_e2_plus.
   rewrite -> (unfold_fetch_decode_execute_loop_bcis ADD nil).
   unfold decode_execute.
   rewrite -> unfold_fetch_decode_execute_loop_nil.
   reflexivity.

   (* minus *)
   (* the structure of this section of the proof is very simlar to that of plus *)
   intro ds_for_lemma.
  (* unfold R.H.S and L.H.S. expressions *)
  rewrite -> (unfold_evaluate_v0_minus e1 e2).
  rewrite -> (unfold_compile_aux_v0_minus e1 e2).
  (* consider cases of evaluate_v0 first *)
  case (evaluate_v0 e1) as [err_msg_e1 | nat_val_e1] eqn : val_of_eval_v0_e1.

  (* evaluate_v0 e1 = Expressible_msg _ *)
  (* introduce lemma we proved about running the append of two bci lists *)
  Check (relation_between_execution_of_two_bcis_and_their_appended_version).
  destruct (relation_between_execution_of_two_bcis_and_their_appended_version
              (compile_aux_v0 e1)
              (compile_aux_v0 e2 ++ SUB :: nil)) as [H_OK H_KO].
  (* use the introduced hypotheses to modify the induction hypotheses, and use this
   * to prove the goal *)
  apply (H_KO ds_for_lemma err_msg_e1) in IH_e1_minus.
  rewrite -> IH_e1_minus.
  reflexivity.

  (* evaluate_v0 e1 = Expressible_nat _ *)
  (* once again, introduce this hypothesis *)
  destruct (relation_between_execution_of_two_bcis_and_their_appended_version
              (compile_aux_v0 e1)
              (compile_aux_v0 e2 ++ SUB :: nil)) as [H_OK H_KO].
  apply (H_OK ds_for_lemma (nat_val_e1 :: ds_for_lemma)) in IH_e1_minus.
  rewrite -> IH_e1_minus.
  clear H_OK H_KO.
  (* now consider cases of (evaluate_v0 e2) *)
  case (evaluate_v0 e2) as [err_msg_e2 | nat_val_e2] eqn : val_of_eval_v0_e2.

  (* evaluate_v0 e2 = Expressible_msg _ *)
  destruct (relation_between_execution_of_two_bcis_and_their_appended_version
              (compile_aux_v0 e2)
              (SUB :: nil)) as [H_OK H_KO].
  apply (H_KO (nat_val_e1 :: ds_for_lemma) err_msg_e2) in IH_e2_minus.
  rewrite -> IH_e2_minus.
  reflexivity.

  (* evaluate_v0 e2 = Expressible_msg _ *)
  (* now we consider the cases of ltb nat_val_e1 and nat_val_e2 *)
  case (ltb nat_val_e1 nat_val_e2) eqn : value_of_ltb_nat_val_e1_nat_val_e2.

  (* ltb nat_val_e1 nat_val_e2 = true *)
  destruct (relation_between_execution_of_two_bcis_and_their_appended_version
              (compile_aux_v0 e2)
              (SUB :: nil)) as [H_OK H_KO].
  apply (H_OK (nat_val_e1 :: ds_for_lemma)
              (nat_val_e2 :: nat_val_e1 :: ds_for_lemma)) in
      IH_e2_minus.
  rewrite -> IH_e2_minus.
  rewrite -> (unfold_fetch_decode_execute_loop_bcis SUB nil).
  unfold decode_execute.
  rewrite -> value_of_ltb_nat_val_e1_nat_val_e2.
  reflexivity.

  (* ltb nat_val_e1 nat_val_e2 = false *)
  destruct (relation_between_execution_of_two_bcis_and_their_appended_version
              (compile_aux_v0 e2)
              (SUB :: nil)) as [H_OK H_KO].
  apply (H_OK (nat_val_e1 :: ds_for_lemma)
              (nat_val_e2 :: nat_val_e1 :: ds_for_lemma)) in
      IH_e2_minus.
  rewrite -> IH_e2_minus.
  rewrite -> (unfold_fetch_decode_execute_loop_bcis SUB nil).
  unfold decode_execute.
  rewrite -> value_of_ltb_nat_val_e1_nat_val_e2.
  rewrite -> unfold_fetch_decode_execute_loop_nil.
  reflexivity.
Qed.

Theorem the_commutative_diagram :
    forall sp : source_program,
      interpret_v0 sp = run (compile_v0 sp).
Proof.
  intro sp.
  case sp as [ae].
  unfold interpret_v0; unfold compile_v0; unfold run.
  (* Use master lemma to finish off the proof *)
  Check (master_lemma_for_commutative_diagram).
  Check (master_lemma_for_commutative_diagram ae nil).
  rewrite ->
          (master_lemma_for_commutative_diagram ae nil).
  case (evaluate_v0 ae) as [err_msg | nat_val].
  reflexivity.
  reflexivity.
Qed.

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

(* Task 10 (if there is time):

   a. Write a Magritte interpreter for the source language
      that does not operate on natural numbers
      but on syntactic representations of natural numbers.

   b. Write a Magritte interpreter for the target language
      that does not operate on natural numbers
      but on syntactic representations of natural numbers.

   c. Prove that interpreting an arithmetic expression with the Magritte source interpreter
      gives the same result as first compiling it and then executing the compiled program
      with the Magritte target interpreter over an empty data stack.

   d. Prove that the Magritte target interpreter is (essentially)
      a left inverse of the compiler, i.e., it is a decompiler.
*)

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

(* Byte-code verification:
   the following verifier symbolically executes a byte-code program
   to check whether no underflow occurs during execution
   and whether when the program completes,
   there is one and one only natural number on top of the stack.
   The second argument of verify_aux is a natural number
   that represents the size of the stack.
*)

Fixpoint verify_aux (bcis : list byte_code_instruction) (n : nat) : option nat :=
  match bcis with
    | nil =>
      Some n
    | bci :: bcis' =>
      match bci with
        | PUSH _ =>
          verify_aux bcis' (S n)
        | _ =>
          match n with
            | S (S n') =>
              verify_aux bcis' (S n')
            | _ =>
              None
          end
      end
  end.

(* Unfold Lemmas *)
Lemma unfold_verify_aux_nil :
  forall (n : nat),
    verify_aux nil n = Some n.
Proof.
  unfold_tactic verify_aux.
Qed.

Lemma unfold_verify_aux_cons :
  forall (bci : byte_code_instruction)
         (bcis : list byte_code_instruction)
         (n : nat),
    verify_aux (bci :: bcis) n =
    match bci with
        | PUSH _ =>
          verify_aux bcis (S n)
        | _ =>
          match n with
            | S (S n') =>
              verify_aux bcis (S n')
            | _ =>
              None
          end
      end.
Proof.
  unfold_tactic verify_aux.
Qed.

Definition verify (p : target_program) : bool :=
  match p with
  | Target_program bcis =>
    match verify_aux bcis 0 with
    | Some n =>
      match n with
      | 1 =>
        true
      | _ =>
        false
      end
    | _ =>
      false
    end
  end.

(* Task 11:
   Prove that the compiler emits code
   that is accepted by the verifier.
*)

Lemma relation_between_bcis_and_verify_aux:
  forall (bci1s bci2s: list byte_code_instruction),
    (forall (n n': nat),
    verify_aux bci1s n = Some n' ->
    verify_aux (bci1s ++ bci2s) n = verify_aux (bci2s) n') /\
    (forall (n : nat),
        verify_aux bci1s n = None ->
        verify_aux (bci1s ++ bci2s) n = None).
Proof.
  Admitted.

Theorem the_compiler_emits_well_behaved_code :
  forall ae : arithmetic_expression,
    verify (compile_v0 (Source_program ae)) = true.
Proof.
  Abort.

(* What are the consequences of this theorem? *)

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

(* end of week-15_a-commutative-diagram.v *)


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearorder.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_parallelNC :
   forall A B C D,
   Par A B C D ->
   nCol A B C /\ nCol A C D /\ nCol B C D /\ nCol A B D.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists M a b c d, (neq A B /\ neq C D /\ Col A B a /\ Col A B b /\ neq a b /\ Col C D c /\ Col C D d /\ neq c d /\ ~ Meet A B C D /\ BetS a M d /\ BetS c M b)) by (conclude_def Par );destruct Tf as [M[a[b[c[d]]]]];spliter.
assert (~ Col A C D).
 {
 intro.
 assert (Col C D A) by (forward_using lemma_collinearorder).
 assert (eq A A) by (conclude cn_equalityreflexive).
 assert (Col A B A) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ Col A B C).
 {
 intro.
 assert (eq C C) by (conclude cn_equalityreflexive).
 assert (Col C D C) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ Col B C D).
 {
 intro.
 assert (Col C D B) by (forward_using lemma_collinearorder).
 assert (eq B B) by (conclude cn_equalityreflexive).
 assert (Col A B B) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ Col A B D).
 {
 intro.
 assert (eq D D) by (conclude cn_equalityreflexive).
 assert (Col C D D) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
close.
Qed.

End Euclid.


Require Import List.
Import ListNotations.
Require Import String.
Open Scope string_scope.
Require Import Bool.
Require Import Sumbool.

Section LambdaChurch.

(* Syntax *)

Definition var_L := string.

Inductive type_L : Type :=
| T_bool : type_L
| T_func : type_L -> type_L -> type_L.

Notation "'Bool'" := T_bool (at level 70).
Notation "t ~> u" := (T_func t u) (right associativity, at level 60).

Inductive expr_L : Type :=
| E_true : expr_L
| E_false : expr_L
| E_var : var_L -> expr_L
| E_lambda : var_L -> type_L -> expr_L -> expr_L
| E_app : expr_L -> expr_L -> expr_L
| E_if : expr_L -> expr_L -> expr_L -> expr_L.

Notation "'TRUE'" := E_true (at level 50).
Notation "'FALSE'" := E_false (at level 50).
Notation "% v" := (E_var v) (at level 50).
Notation "p $ q" := (E_app p q) (left associativity, at level 40).
Notation "\ x 'AT' t 'IS' e" := (E_lambda x t e) (at level 30).
Notation "'WHEN' b 'THEN' p 'ELSE' q" := (E_if b p q) (at level 20).

(* Context *)

Definition context_L := var_L -> option type_L.

Fixpoint add_ctx (ctx : context_L) (v : var_L) (t : type_L) : context_L :=
fun v' => if string_dec v v' then Some t else ctx v'.

(* Typing rules *)

Inductive typing (c : context_L) : expr_L -> type_L -> Prop :=
| Type_true : typing c E_true T_bool
| Type_false : typing c E_false T_bool
| Type_var v : forall t : type_L, c v = Some t -> typing c (E_var v) t
| Type_lambda v t e : forall u : type_L, typing (add_ctx c v t) e u
                        -> typing c (E_lambda v t e) (T_func t u)
| Type_app e1 e2 : forall (t u : type_L), typing c e1 (T_func t u)
                     -> typing c e2 t -> typing c (E_app e1 e2) u
| Type_if b e1 e2 : forall (t : type_L), typing c b T_bool -> typing c e1 t
                      -> typing c e2 t -> typing c (E_if b e1 e2) t.

Fixpoint eq_type (t u : type_L) : bool :=
match t, u with
| T_bool, T_bool => true
| T_func t1 t2, T_func u1 u2 => eq_type t1 u1 && eq_type t2 u2
| _, _ => false
end.

Fixpoint do_infer (c : context_L) (exp : expr_L) : option type_L :=
match exp with
| E_true => Some T_bool
| E_false => Some T_bool
| E_var v => c v
| E_lambda v t e => match do_infer (add_ctx c v t) e with
                    | Some u => Some (T_func t u)
                    | None => None
                    end
| E_app e1 e2 => match do_infer c e1 with
                 | Some (T_func t u) => if do_check c e2 t then Some u else None
                 | _ => None
                 end
| E_if b e1 e2 => if do_check c b T_bool
                  then match do_infer c e1 with
                       | Some t => if do_check c e2 t then Some t else None
                       | None => None
                       end
                  else None
end
with do_check (c : context_L) (exp : expr_L) (tp : type_L) : bool :=
match exp with
| E_true | E_false => match tp with
                      | T_bool => true
                      | _ => false
                      end
| E_var v => match c v with
             | Some t' => eq_type t' tp
             | None => false
             end
| E_lambda v t e => match tp with
                    | T_func t' u' => eq_type t' t
                                      && do_check (add_ctx c v t) e u'
                    | _ => false
                    end
| E_app e1 e2 => match do_infer c e1 with
                 | Some (T_func t' u') => eq_type u' tp && do_check c e2 t'
                 | _ => false
                 end
| E_if b e1 e2 => do_check c b T_bool && do_check c e1 tp && do_check c e2 tp
end.

(* Lemmas *)

Ltac rewrite_refl H := rewrite H ; reflexivity.

Ltac rewrite_refl_2 H1 H2 := rewrite H1 ; rewrite H2 ; reflexivity.

Lemma eq_type_eq :
forall (t0 t1 : type_L), eq_type t0 t1 = true <-> t0 = t1.
Proof.
induction t0 ; destruct t1 ; split ; intros ; try reflexivity
; try solve [inversion H].
* inversion H.
  apply andb_true_iff in H1.
  destruct H1 as [G G0].
  destruct (IHt0_1 t1_1) as [IHt0_1L IHt0_1P].
  destruct (IHt0_2 t1_2) as [IHt0_2L IHt0_2P].
  rewrite_refl_2 (IHt0_1L G) (IHt0_2L G0).
* simpl.
  destruct (IHt0_1 t1_1) as [IHt0_1L IHt0_1P].
  destruct (IHt0_2 t1_2) as [IHt0_2L IHt0_2P].
  rewrite IHt0_1P
  ; try rewrite IHt0_2P
  ; inversion H
  ; reflexivity.
Qed.

Lemma andb_true :
forall a b, andb a b = true <-> a = true /\ b = true.
Proof.
split.
* destruct a ; destruct b ; intros ; simpl in * ; try discriminate ; split
  ; assumption.
* intros.
  destruct H.
  rewrite_refl_2 H H0.
Qed.

Lemma context_var_dec :
forall (c : context_L) (v : var_L),
  {t : type_L | c v = Some t} + {c v = None}.
Proof.
intros.
destruct (c v).
* left.
  exists t.
  reflexivity.
* right.
  reflexivity.
Qed.

Ltac split_andb H := apply andb_true in H
                     ; let g0 := fresh "G" in
                       let g1 := fresh "G" in
                       destruct H as [g0 g1].

Ltac eq H := apply eq_type_eq in H ; subst.

Ltac eq_reflexivity H := eq H ; reflexivity.

Ltac eq_type_and_true := apply andb_true_iff
                         ; split
                         ; try apply eq_type_eq
                         ; reflexivity.

(* Equivalence proofs *)

Lemma do_check_is_do_infer :
forall (e : expr_L) (c : context_L) (t : type_L),
  do_check c e t = true -> do_infer c e = Some t.
Proof.
induction e ; intros.
* destruct t ; simpl in * ; [reflexivity | discriminate].
* destruct t ; simpl in * ; [reflexivity | discriminate].
* simpl in *.
  destruct (c v) ; [eq_reflexivity H | discriminate].
* simpl in H.
  destruct t0 ; try discriminate.
  split_andb H.
  eq G.
  specialize (IHe (add_ctx c v t) t0_2 G0).
  simpl.
  rewrite_refl IHe.
* simpl in *.
  destruct (do_infer c e1) ; try destruct t0 ; try discriminate.
  split_andb H.
  rewrite G0.
  eq_reflexivity G.
* simpl in H.
  split_andb H.
  split_andb G.
  simpl.
  rewrite G1.
  rewrite_refl_2 (IHe2 c t G2) G0.
Qed.

Lemma do_infer_is_do_check :
forall (e : expr_L) (c : context_L) (t : type_L),
  do_infer c e = Some t -> do_check c e t = true.
Proof.
induction e ; intros ; simpl in *.
* inversion H.
  reflexivity.
* inversion H.
  reflexivity.
* rewrite H.
  apply eq_type_eq.
  reflexivity.
* remember (do_infer (add_ctx c v t) e) as I.
  destruct I ; try discriminate.
  destruct t0 ; try inversion H.
  subst.
  symmetry in HeqI.
  apply IHe in HeqI.
  rewrite HeqI.
  eq_type_and_true.
* destruct (do_infer c e1) ; try discriminate.
  destruct t0 ; try discriminate.
  destruct (do_check c e2 t0_1) ; try discriminate.
  inversion H.
  subst.
  eq_type_and_true.
* destruct (do_check c e1 T_bool) ; try discriminate.
  simpl.
  remember (do_infer c e2) as I.
  destruct I ; try discriminate.
  symmetry in HeqI.
  apply IHe2 in HeqI.
  destruct (sumbool_of_bool (eq_type t0 t)).
** eq e.
   rewrite HeqI.
   simpl.
   destruct (do_check c e3 t) ; [reflexivity | discriminate].
** apply not_true_iff_false in e.
   destruct (do_check c e3 t0) ; try discriminate.
   inversion H.
   eq H1.
   contradiction.
Qed.

Lemma typing_is_do_infer :
forall (e : expr_L) (c : context_L) (t : type_L),
  typing c e t -> do_infer c e = Some t.
Proof.
induction 1 ; intros ; simpl.
* reflexivity.
* reflexivity.
* assumption.
* rewrite_refl IHtyping.
* rewrite IHtyping1.
  apply do_infer_is_do_check in IHtyping2.
  rewrite_refl IHtyping2.
* apply do_infer_is_do_check in IHtyping1.
  rewrite IHtyping1.
  rewrite IHtyping2.
  apply do_infer_is_do_check in IHtyping3.
  rewrite_refl IHtyping3.
Qed.

Lemma do_infer_is_typing :
forall (e : expr_L) (c : context_L) (t : type_L),
  do_infer c e = Some t -> typing c e t.
Proof.
induction e ; intros ; simpl in H.
* inversion H.
  subst.
  constructor.
* inversion H.
  subst.
  constructor.
* constructor.
  assumption.
* remember (do_infer (add_ctx c v t) e) as I.
  destruct I ; try discriminate.
  inversion H.
  subst.
  constructor.
  apply IHe.
  symmetry.
  assumption.
* remember (do_infer c e1) as I1.
  destruct I1 ; try destruct t0 ; try discriminate.
  remember (do_check c e2 t0_1) as I2.
  destruct I2 ; try discriminate.
  inversion H.
  subst.
  apply Type_app with (t:=t0_1)
  ; [apply IHe1 | apply IHe2 ; apply do_check_is_do_infer] ; symmetry
  ; assumption.
* simpl in H.
  remember (do_check c e1 T_bool) as I1.
  remember (do_infer c e2) as I2.
  destruct I1 ; try destruct t0 ; try destruct I2 ; try discriminate.
  remember (do_check c e3 t0) as I3.
  destruct I3 ; try discriminate.
  inversion H.
  subst.
  constructor ; [apply IHe1 ; apply do_check_is_do_infer
                | apply IHe2
                | apply IHe3 ; apply do_check_is_do_infer]
  ; symmetry ; assumption.
Qed.

(* Typing proof *)

Theorem make_typecheck_1 :
forall (e : expr_L) (c : context_L), option {t : type_L | typing c e t}.
Proof.
induction e ; intros.
* refine (Some (exist _ T_bool _)).
  constructor.
* refine (Some (exist _ T_bool _)).
  constructor.
* destruct (context_var_dec c v).
** destruct s.
   refine (Some (exist _ x _)).
   constructor.
   assumption.
** refine None.
* destruct (IHe (add_ctx c v t)).
** destruct s.
   refine (Some (exist _ (T_func t x) _)).
   constructor.
   assumption.
** refine None.
* destruct (IHe2 c).
** destruct s.
   destruct (IHe1 c).
*** destruct s.
    destruct x0.
**** refine None.
**** destruct (sumbool_of_bool (eq_type x x0_1)).
***** apply eq_type_eq in e.
      subst.
      refine (Some (exist _ x0_2 _)).
      apply Type_app with (t:=x0_1) ; assumption.
***** refine None.
*** refine None.
** refine None.
* destruct (IHe1 c).
** destruct s.
   destruct x.
*** destruct (IHe2 c).
**** destruct s.
     destruct (IHe3 c).
***** destruct s.
      destruct (sumbool_of_bool (eq_type x x0)).
****** apply eq_type_eq in e.
       subst.
       refine (Some (exist _ x0 _)).
       constructor ; assumption.
****** refine None.
***** refine None.
**** refine None.
*** refine None.
** refine None.
Qed.

Theorem make_typecheck_2 :
forall (e : expr_L) (c : context_L), option {t : type_L | typing c e t}.
Proof.
refine (
  fix tp (ex : expr_L) (ct : context_L) :=
    match ex with
    | E_true => Some (exist _ T_bool _)
    | E_false => Some (exist _ T_bool _)
    | E_var v => match context_var_dec ct v with
                 | inleft (exist _ t d) => Some (exist _ t _)
                 | inright _ => None
                 end
    | E_lambda v t e0 => match tp e0 (add_ctx ct v t) with
                         | Some (exist _ u d) =>
                           Some (exist _ (T_func t u) _)
                         | None => None
                         end
    | E_app e1 e2 => match tp e1 ct, tp e2 ct with
                     | Some d1, Some d2 => _
                     | _, _ => None
                     end
    | E_if b e1 e2 => match tp b ct, tp e1 ct, tp e2 ct with
                      | Some (exist _ tb db), Some d1, Some d2 => _
                      | _, _, _ => None
                      end
    end).
* constructor.
* constructor.
* constructor.
  assumption.
* constructor.
  assumption.
* destruct d1.
  destruct x.
** refine None.
** destruct d2.
   destruct (sumbool_of_bool (eq_type x x1)).
*** apply eq_type_eq in e.
    subst.
    refine (Some (exist _ x2 _)).
    apply Type_app with (t:=x1) ; assumption.
*** refine None.
* destruct tb.
** destruct d1.
   destruct d2.
   destruct (sumbool_of_bool (eq_type x x0)).
*** apply eq_type_eq in e.
    subst.
    refine (Some (exist _ x0 _)).
    constructor ; assumption.
*** refine None.
** refine None.
Qed.

End LambdaChurch.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Vector theory on real numbers
  author    : ZhengPu Shi
  date      : 2021.12

  ref:
  1. 《高等数学学习手册》徐小湛，p173
  2. Vector Calculus - Michael Corral
  3. https://github.com/coq/coq/blob/master/test-suite/success/Nsatz.v
     注意，这里有Coq库中定义的几何学形式化内容，包括点，平行，共线等。
*)

Require Export Vector.
Require Export RMatrix.

Open Scope R.
Open Scope mat_scope.

(* ======================================================================= *)
(** ** 从向量理论 导出的 实数域向量理论 *)

Definition vec := vec (A:=R).

Definition v2f {n} (v : vec n) := v2f v.

Definition f2v {n} f : vec n := f2v n f.

Definition vnth {n} (v : vec n) i := vnth v i.

Definition veq {n} (v1 v2 : vec n) := veq v1 v2.
Global Infix "==" := veq : vec_scope.

Lemma veq_refl : forall {n} (v : vec n), v == v.
Proof. intros. apply veq_refl. Qed.

Lemma veq_sym : forall {n} (v1 v2 : vec n), v1 == v2 -> v2 == v1.
Proof. intros. apply veq_sym; auto. Qed.

Lemma veq_trans : forall {n} (v1 v2 v3 : vec n),
    v1 == v2 -> v2 == v3 -> v1 == v3.
Proof. intros. apply veq_trans with v2; auto. Qed.

Hint Resolve veq_refl : vec.
Hint Resolve veq_sym : vec.
Hint Resolve veq_trans : vec.

Lemma veq_dec : forall {n} (v1 v2 : vec n), {v1 == v2} + {~(v1 == v2)}.
Proof. intros. apply veq_dec. Qed.

Definition t2v_2 (t : T2) : vec 2 := t2v_2 (A0:=0) t.

Definition v2t_2 (v : vec 2) : T2 := v2t_2 v.

Definition t2v_3 (t : T3) : vec 3 := t2v_3 (A0:=0) t.

Definition v2t_3 (v : vec 3) : T3 := v2t_3 v.

Definition t2v_4 (t : T4) : vec 4 := t2v_4 (A0:=0) t.

Definition v2t_4 (v : vec 4) : T4 := v2t_4 v.

Lemma v2t_t2v_id_2 : forall (t : T2), v2t_2 (t2v_2 t) = t.
Proof. intros. apply v2t_t2v_id_2. Qed.

Lemma t2v_v2t_id_2 : forall (v : vec 2), t2v_2 (v2t_2 v) == v.
Proof. intros. apply t2v_v2t_id_2. Qed.

Definition v2l {n} (v : vec n) := v2l v.

Definition l2v n l : vec n := l2v (A0:=0) l.

Lemma v2l_length : forall {n} (v : vec n), length (v2l v) = n.
Proof. intros. apply v2l_length. Qed.

Lemma v2l_l2v_id : forall {n} l, length l = n -> v2l (l2v n l) = l.
Proof. intros. apply v2l_l2v_id; auto. Qed.

Lemma l2v_v2l_id : forall {n} (v : vec n), l2v _ (v2l v) == v.
Proof. intros. apply l2v_v2l_id. Qed.

Definition vec0 n : vec n := vec0 (A0:=0).

Definition vzero {n} (v : vec n) := vzero (A0:=0) v.

Definition vnonzero {n} (v : vec n) := vnonzero (A0:=0) v.

Lemma vec0_eq_mat0 : forall {n}, vec0 n == mat0 n 1.
Proof. apply vec0_eq_mat0. Qed.

Lemma vzero_dec : forall {n} (v : vec n), {vzero v} + {vnonzero v}.
Proof. intros. apply vzero_dec. Qed.

Definition vmap {n} (v : vec n) f : vec n := vmap v f.

Definition vmap2 {n} (v1 v2 : vec n) f : vec n := vmap2 v1 v2 f.

Definition vdot {n} (v1 v2 : vec n) :=
  vdot v1 v2 (add0:=Rplus) (zero0:=0) (mul0:=Rmult).

Definition vlen_sqr {n} (v : vec n) : R := vdot (n:=n) v v.

Definition vadd {n} (v1 v2 : vec n) : vec n := vadd v1 v2 (add0:=Rplus).
Global Infix "+" := vadd : vec_scope.

Lemma vadd_comm : forall {n} (v1 v2 : vec n), v1 + v2 == v2 + v1.
Proof. intros. apply vadd_comm. Qed.

Lemma vadd_assoc : forall {n} (v1 v2 v3 : vec n),
    (v1 + v2) + v3 == v1 + (v2 + v3).
Proof. intros. apply vadd_assoc. Qed.

Lemma vadd_0_l : forall {n} (v : vec n), (vec0 n) + v == v.
Proof. intros. apply vadd_0_l. Qed.

Lemma vadd_0_r : forall {n} (v : vec n), v + (vec0 n) == v.
Proof. intros. apply vadd_0_r. Qed.

Definition vopp {n} (v : vec n) : vec n := vopp v (opp:=Ropp).
Global Notation "- v" := (vopp v) : vec_scope.

Lemma vadd_vopp : forall {n} (v : vec n), v + (-v) == (vec0 n).
Proof. intros. apply vadd_opp. Qed.

Definition vsub {n} (v1 v2 : vec n) := vsub v1 v2 (add0:=Rplus) (opp:=Ropp).
Global Infix "-" := vsub : vec_scope.

Definition vcmul {n} a (v : vec n) := vcmul a v (mul0:=Rmult).
Global Infix "c*" := vcmul : vec_scope.

Definition vmulc {n} (v : vec n) a := vmulc v a (mul0:=Rmult).
Global Infix "*c" := vmulc : vec_scope.

Lemma vmulc_eq_vcmul : forall {n} a (v : vec n), v *c a == a c* v.
Proof. intros. apply vmulc_eq_vcmul. Qed.

Lemma vcmul_assoc : forall {n} a b (v : vec n), (a * b)%R c* v == a c* (b c* v).
Proof. intros. apply vcmul_assoc. Qed.

Lemma vcmul_perm : forall {n} a b (v : vec n), a c* (b c* v) == b c* (a c* v).
Proof. intros. apply vcmul_perm. Qed.

Lemma vcmul_add_distr_l : forall {n} a (v1 v2 : vec n),
    a c* (v1 + v2) == a c* v1 + a c* v2.
Proof. intros. apply vcmul_add_distr_l. Qed.

Lemma vcmul_add_distr_r : forall {n} a b (v : vec n),
    (a + b) c* v == a c* v + b c* v.
Proof. intros. apply vcmul_add_distr_r. Qed.

Lemma vcmul_1_l : forall {n} (v : vec n), 1 c* v == v.
Proof. intros. apply vcmul_1_l. Qed.

Lemma vcmul_0_l : forall {n} (v : vec n), 0 c* v == vec0 n.
Proof. intros. apply vcmul_0_l. Qed.

Lemma vec_eq_vcmul_imply_coef_neq0 : forall {n} (v1 v2 : vec n) k,
    vnonzero v1 -> vnonzero v2 -> v1 == k c* v2 -> k <> 0.
Proof. intros. apply vec_eq_vcmul_imply_coef_neq0 with v1 v2; auto. Qed.

(* ======================================================================= *)
(** ** 新增的 实数域向量理论 *)

(** 向量的长度，模，范数（欧几里得范数）。存在性的构造，适合证明 *)
Definition vlen {n} (v : vec n) : R := sqrt (vlen_sqr v).

(** 非零向量的单位化 *)

(* 旧的定义，提供 v 非零的证明。修改原因：在定义中没必要提及性质 *)
Definition vnormalize' {n} (v : vec n) (H : vnonzero (n:=n) v) : vec n :=
  let k := 1 / (vlen v) in
  vcmul k v.
Definition vnormalize {n} (v : vec n) : vec n :=
  let k := 1 / (vlen v) in
  vcmul k v.

(** 长度为0的向量具有唯一性 *)
(* Lemma vec_len0_is_vec0 : forall v : vec 0, v == vec0 0. *)
Lemma vec_len0_uniq : forall v : vec 0, v == vec0 0.
Proof.
  intros. apply meq_iff. intro. intros. easy.
Qed.

(** 非零向量v的k倍等于0，则k必为0 *)
Lemma vcmul_nonzero_eq0_imply_k0 : forall {n} (v : vec n) k,
    vnonzero v -> k c* v == vec0 n -> k = 0.
Proof.
  intros. destruct v as [g].
  unfold vnonzero,vzero,vec0,mat0 in *.
  unfold veq in *. meq_simp.
  (* 思路：特例化 H0，导出矛盾 *)
  (* 判断 k 是否为0 *)
  destruct (Req_EM_T k 0); auto.
  (* 先看n是否为零，分两种情况 *)
  destruct n.
  - cbv in H.
    exfalso. apply H. intros. lia.
  - exfalso. cbv in H. cbv in H0.
    apply H. intros. apply (H0 i j H1) in H2.
    (* k<>0 /\ k * (g i j) = 0 -> g i j = 0 *)
    apply Rmult_integral in H2. destruct H2; try easy.
Qed.

(** 向量平行（共线）：零向量与任何向量平行，或者非零向量是k倍的关系
    定义：u和v中，一个是另一个的数乘。
    平行：parallel
    共线：colinear

    遗留问题：主流做法是零向量与任何向量都平行、都垂直。
    是否可以：仅考虑非零向量的平行，零向量不考虑。
    一个原因是：考虑零向量后，平行传递性不完美了。
 *)

(* 关于零向量的平行？
    1. https://www.zhihu.com/question/489006373
    两个方面:
    a. “平行”或“不平行”是对两个可以被识别的方向的比较，对于零向量，“方向”是不可
      识别的，或说，是不确定的。从这个角度讲，“平行”这个概念不该被用到评价两个
      零向量的关系上的。
    b. 不过，两个零向量是“相等”的，对于向量而言，“相等”这件事包含了大小和方向
      的相等，这么说来，说两个零向量“方向”相等，也就是“平行”或也是说得通的。
 *)

(* 定义1：v1是v2的k倍，或者 v2是v1的k倍。*)
Definition vparallel_ver1 {n} (v1 v2 : vec n) : Prop :=
  exists k, (v1 == k c* v2 \/ v2 == k c* v1).

(* 定义2：v1 是 0，或者 v2 是 0，或者 v1 是 v2 的 k 倍 *)
Definition vparallel_ver2 {n} (v1 v2 : vec n) : Prop :=
  (vzero v1) \/ (vzero v2) \/ (exists k, v1 == k c* v2).

(* 证明这两个定义等价 *)
Lemma vparallel_ver1_eq_ver2 : forall {n} (v1 v2 : vec n),
    vparallel_ver1 v1 v2 <-> vparallel_ver2 v1 v2.
Proof.
  intros. unfold vparallel_ver1, vparallel_ver2.
  unfold vzero, vnonzero. split; intros.
  - destruct H. destruct H.
    + right. right. exists x. auto.
    + destruct (veq_dec v1 (vec0 n)); auto.
      destruct (veq_dec v2 (vec0 n)); auto.
      right. right. exists (R1/x). rewrite H.
      apply meq_iff.
      intros i j Hi Hj. destruct v1 as [g1], v2 as [g2]. simpl in *.
      field.
      apply vec_eq_vcmul_imply_coef_neq0 in H; auto.
  - destruct H as [H1 | [H2 | H3]].
    + exists R0. left. cbv in *. intros. rewrite H1; auto. ring.
    + exists R0. right. cbv in *. intros. rewrite H2;auto. ring.
    + destruct H3. exists x. left; auto.
Qed.

(** 向量平行谓词的定义 *)
Definition vparallel {n} (v0 v1 : vec n) : Prop :=
  vparallel_ver2 v0 v1.

Notation "v0 // v1" := (vparallel (v0) (v1)) (at level 70) : vec_scope.

(** * 向量平行的性质 *)

(** 向量平行是等价关系 *)

(** 自反性 *)
Lemma vparallel_refl : forall {n} (v : vec n), v // v.
Proof.
  intros. unfold vparallel,vparallel_ver2. right. right. exists 1.
  rewrite mcmul_1_l. easy.
Qed.

(** 对称性 *)
Lemma vparallel_sym : forall {n} (v0 v1 : vec n), v0 // v1 -> v1 // v0.
Proof.
  intros. unfold vparallel,vparallel_ver2 in *.
  assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
  assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
  destruct H0.
  - right; left; auto.
  - destruct H1.
    + left; auto.
    + destruct H; auto. destruct H; auto. destruct H.
      right; right. exists (1/x). rewrite H.
      rewrite <- vcmul_assoc.
      replace (1/x * x)%R with 1.
      rewrite vcmul_1_l; auto with vec.
      field.
      apply (vec_eq_vcmul_imply_coef_neq0 v0 v1); auto.
Qed.

(** 传递性 *)
(* 要求v1是非零向量。因为若v1为0，v0//v1, v1//v2, 但 v0,v2 不平行 *)
Lemma vparallel_trans : forall {n} (v0 v1 v2 : vec n),
    vnonzero v1 -> v0 // v1 -> v1 // v2 -> v0 // v2.
Proof.
  intros. unfold vparallel, vparallel_ver2 in *.
  assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
  assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
  assert ({vzero v2} + {vnonzero v2}). apply meq_dec.
  destruct H2.
  - left; auto.
  - destruct H4.
    + right; left; auto.
    + right; right.
      destruct H3.
      * destruct H0; try contradiction.
      * destruct H0,H1; try contradiction.
        destruct H0,H1; try contradiction.
        destruct H0,H1.
        exists (x*x0)%R. rewrite H0,H1. apply mcmul_assoc.
Qed.

(** 数乘非零向量得到非零向量，则该系数必不为 0 *)
Lemma vcmul_vnonzero_neq0_imply_k_neq0 :
  forall {n} (v : vec n) (H : vnonzero v) k, ~(k c* v == vec0 n) -> k <> 0.
Proof.
  intros. intro. subst. rewrite vcmul_0_l in H0. destruct H0. easy.
Qed.

(** 两个非零向量k倍相等，k唯一 *)
Lemma vcmul_vnonzero_eq_iff_unique_k :
  forall {n} (v : vec n) (H : vnonzero v) k1 k2,
    k1 c* v == k2 c* v -> k1 = k2.
Proof.
  intros. destruct v as [g].
  cbv in H. cbv in H0.
  (* ∀i(f(i)=0 /\ k1*f(i) = k2*f(i)) -> k1 = k2 *)
  destruct (Req_EM_T k1 k2); auto.
  destruct H. intros. (* 消去了全称量词 *)
  specialize (H0 i j H H1).
  ra.
Qed.

(** 非零向量k倍相等于自己，则k为1 *)
Lemma vcmul_vnonzero_eq_self_iff_k1 :
  forall {n} (v : vec n) (H : vnonzero v) k,
    k c* v == v -> k = 1.
Proof.
  intros. destruct v as [g]. cbv in H,H0.
  (* 证明 k = 1，老的方法，先得到 k <> 1 的前提，然后消去全称量词 *)
  destruct (Req_EM_T k 1); auto.
  destruct H. intros. (* 消去了全称量词 *)
  specialize (H0 i j H H1).
  (* forall k, (forall x, k * x = x -> x = 0 \/ (x <> 0 /\ k = 1)). *)
  ra.
Qed.

(** 非零向量平行，则存在唯一比例系数k *)
Lemma vparallel_vnonezero_imply_unique_k :
  forall {n} (v1 v2 : vec n) (H1 : vnonzero v1) (H2 : vnonzero v2),
    v1 // v2 -> (exists ! k, v1 == k c* v2).
Proof.
  intros.
  destruct H; try contradiction.
  destruct H; try contradiction.
  destruct H. exists x. unfold unique. split; auto.
  intros. apply vcmul_vnonzero_eq_iff_unique_k with (v:=v2); auto.
  rewrite <- H,H0. easy.
Qed.

(** 给定 向量v1，v2，
    v1<>0 /\ v1//v2 <=> 存在唯一实数 a 使得 v2 = a * v1 *)
Lemma vparallel_iff1 : forall {n} (v1 v2 : vec n) (H : vnonzero v1),
    (v1 // v2) <-> (exists ! a, v2 == a c* v1).
Proof.
  intros.
  split; intros.
  - destruct (veq_dec v2 (vec0 n)).
    + exists 0. split.
      * rewrite m. rewrite vcmul_0_l. auto with vec.
      * intros. rewrite m in H1.
        apply eq_sym. apply veq_sym in H1.
        apply vcmul_nonzero_eq0_imply_k0 in H1; auto.
    + unfold vparallel,vparallel_ver2 in *.
      destruct H0; try easy. destruct H0; try easy.
      destruct H0. exists (1/x). split.
      * rewrite H0. intros i j Hi Hj. simpl. field.
        apply vcmul_vnonzero_neq0_imply_k_neq0 with (v2); auto.
        rewrite <- H0. auto.
      * intros. rewrite H0 in H1.
        rewrite <- vcmul_assoc in H1.
        apply veq_sym in H1.
        apply vcmul_vnonzero_eq_self_iff_k1 in H1; auto.
        rewrite <- H1. field.
        apply vcmul_vnonzero_neq0_imply_k_neq0 with (v2); auto.
        rewrite <- H0. auto.
  - destruct H0. destruct H0. apply vparallel_sym.
    unfold vparallel, vparallel_ver2.
    right. right. exists x. auto.
Qed.

(* ======================================================================= *)
(** *** 3-dim vector operations *)

(** V3斜对称矩阵 *)
Definition skew_sym_mat_of_v3 (v : vec 3) : mat 3 3 :=
  let '(x,y,z) := v2t_3 v in
  mk_mat_3_3
    0    (-z)  y
    z     0    (-x)
    (-y)  x     0.

(** V3叉乘，向量积 *)
Definition vcross3 (v1 v2 : vec 3) : vec 3 := ((skew_sym_mat_of_v3 v1) * v2).

(** 矩阵是否为SO3（李群，旋转群） *)
Definition so3 (m : mat 3 3) : Prop :=
  let so3_mul_unit : Prop := ((m ') * m) = mat1 3 in
  let so3_det : Prop := (det3 m) = 1 in
  so3_mul_unit /\ so3_det.

(** 计算两个向量的夹角 *)
Definition vangle3 (v0 v1 : vec 3) : R :=
  acos (m2t_1x1 (v0 ᵀ * v1)).

(** (1,0,0) 和 (1,1,0) 的夹角是 45度，即 π/4 *)
Example vangle3_ex1 : vangle3 (l2v 3 [1;0;0]) (l2v 3 [1;1;0]) = PI/4.
Proof.
  compute.
      (* Search acos. *)
Abort. (* 暂不知哪里错了，要去查叉乘的意义 *)

(** 根据两个向量来计算旋转轴 *)
Definition rot_axis_by_twovec (v0 v1 : vec 3) : vec 3 :=
  let s : R := (vlen v0 * vlen v1)%R in
  s c* (vcross3 v0 v1).

(* 谓词：两向量不共线（不平行的） *)
(* Definition v3_non_colinear (v0 v1 : V3) : Prop :=
    v0 <> v1 /\ v0 <> (-v1)%M.
 *)


Require Import XR_Rmin.
Require Import XR_Rle_dec.
Require Import XR_Rle_trans.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Rle_min_compat_r : forall x y z, x <= y -> Rmin x z <= Rmin y z.
Proof.
  intros x y z.
  intro h.
  unfold Rmin.
  destruct (Rle_dec x z) as [ hminxl | hminxr ] ;
  destruct (Rle_dec y z) as [ hminyl | hminyr ].
  { exact h. }
  { exact hminxl. }
  {
    apply Rle_trans with x.
    {
      left.
      apply Rnot_le_lt.
      exact hminxr.
    }
    { exact h. }
  }
  {
    right.
    reflexivity.
  }
Qed.


Require Import Ensembles Relations.
Set Implicit Arguments.
Implicit Arguments In [U].

Definition var := nat.
Inductive formula : Set :=
| Atom : var -> formula
| Bot : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula
| Box : formula -> formula
| Dia : formula -> formula.
Infix "'->" := Imp (at level 70, right associativity).
Infix "'\/" := Or (at level 60).
Infix "'/\" := And (at level 50).
Notation "[]" := Box.
Notation "<>" := Dia.
(* Definition Not f := f '-> Bot.  *)
(* Definition Top := Bot '-> Bot. *)
Coercion Atom : var >-> formula.

Inductive provable : Ensemble formula -> formula -> Prop :=
| By_axiom : forall fs f, In fs f -> provable fs f
| By_K : forall fs f g, provable fs (f '-> g '-> f)
| By_S : forall fs f g h,
  provable fs ((f '-> g '-> h) '-> (f '-> g) '-> (f '-> h))
| By_proj1 : forall fs f g, provable fs (f '/\ g '-> f)
| By_proj2 : forall fs f g, provable fs (f '/\ g '-> g)
| By_conj : forall fs f g, provable fs (f '-> g '-> f '/\ g)
| By_in1 : forall fs f g, provable fs (f '-> f '\/ g)
| By_in2 : forall fs f g, provable fs (g '-> f '\/ g)
| By_case : forall fs f g h,
  provable fs ((f '-> h) '-> (g '-> h) '-> (f '\/ g '-> h))
| By_exfalso : forall fs f, provable fs (Bot '-> f)
| By_KBox : forall fs f g, provable fs ([](f '-> g) '-> []f '-> []g)
| By_KDia : forall fs f g, provable fs ([](f '-> g) '-> <>f '-> <>g)
| By_NDia : forall fs, provable fs (<>Bot '-> Bot)
| By_MP : forall fs f g,
  provable fs (f '-> g) -> provable fs f -> provable fs g
| By_Nec : forall fs f, provable (Empty_set _) f -> provable fs ([] f).

Hint Constructors provable.

Module Type KRIPKE_MODEL.
  Parameter W : Type.
  Parameter R Ri : relation W.
  Axiom Ri_refl : reflexive _ Ri.
  Axiom Ri_trans : transitive _ Ri.
  Infix "<=" := Ri.
  Parameter V : W -> var -> Prop.
  Axiom monotone : forall x y p, V x p -> x <= y -> V y p.
End KRIPKE_MODEL.

Module Kripke_Semantics (K : KRIPKE_MODEL).
  Import K.

  Fixpoint satisfies x f :=
    match f with
      | Atom p => V x p
      | Bot => False
      | And f f' => satisfies x f /\ satisfies x f'
      | Or f f' => satisfies x f \/ satisfies x f'
      | Imp f f' => forall y, x <= y -> satisfies y f -> satisfies y f'
      | Box f => forall y z, x <= y -> R y z -> satisfies z f
      | Dia f => forall y, x <= y -> exists z, R y z /\ satisfies z f
    end.

  Hint Resolve Ri_trans Ri_refl monotone.
  Lemma hereditary : forall f x y,
    satisfies x f -> x <= y -> satisfies y f.
    induction f; simpl; intuition eauto.
  Qed.

  Hint Extern 0 =>
    match goal with [ H : In (Empty_set _) _ |- _ ] => inversion H end.
  Theorem soundness : forall fs f, provable fs f ->
    forall x, (forall g, In fs g -> satisfies x g) -> satisfies x f.
    induction 1; simpl in *; intuition; eauto using hereditary.
    destruct (H3 y1); intuition eauto.

    destruct (H1 y); intuition.
  Qed.

End Kripke_Semantics.

Lemma deduction_theorem' : forall fs fs' f g,
  provable fs' g -> fs' = Add _ fs f -> provable fs (f '-> g).
  induction 1; intro; subst; [| eauto ..].
  inversion H; try inversion H0; subst; eauto.
  Existential 1 := Bot.
  Existential 1 := Bot.
  Existential 1 := Bot.
Qed.

Lemma deduction_theorem : forall fs f g,
  provable (Add _ fs f) g -> provable fs (f '-> g).
  eauto using deduction_theorem'.
Qed.

Lemma weakening : forall fs f g, provable fs f -> provable (Add _ fs g) f.
  induction 1; solve [repeat constructor; auto | eauto].
Qed.

Hint Constructors Union Singleton.
Hint Extern 1 (provable (Add _ _ _) _) => unfold Add.

Lemma converse_deduction_theorem :
  forall fs f g, provable fs (f '-> g) -> provable (Add _ fs f) g.
  intros; apply (@By_MP _ f g); auto using weakening.
Qed.

Module Canonical_Model <: KRIPKE_MODEL.
  Definition prime fs :=
    forall f g, provable fs (f '\/ g) -> provable fs f \/ provable fs g.
  Definition consistent fs := ~provable fs Bot.

  Definition W := { P : Ensemble formula * formula |
    prime (fst P) /\ consistent (fst P) /\ ~provable (fst P) (<> (snd P)) }.

  Definition Ri (T U : W) :=
    forall f, provable (fst (proj1_sig T)) f -> provable (fst (proj1_sig U)) f.
  Definition R (T U : W) :=
    (forall f, provable (fst (proj1_sig T)) ([]f) ->
      provable (fst (proj1_sig U)) f) /\
    ~provable (fst (proj1_sig U)) (snd (proj1_sig T)).

  Hint Unfold R Ri Included.
  Infix "<=" := Ri.
  Lemma Ri_refl : forall T, T <= T.
    auto.
  Qed.
  Lemma Ri_trans : forall T U V, T <= U -> U <= V -> T <= V.
    auto.
  Qed.
  Definition V (T : W) (p : var) := provable (fst (proj1_sig T)) p.
  Hint Unfold V.
  Lemma monotone : forall x y p, V x p -> x <= y -> V y p.
    intuition.
  Qed.
End Canonical_Model.

Module Canonical_Model_facts.
  Module M := Kripke_Semantics Canonical_Model.

  Import Canonical_Model M.

  Definition boxinv fs f := provable fs ([] f).

  Lemma boxinv_closed : forall fs f,
    provable (boxinv fs) f ->  In (boxinv fs) f.
    intros fs f; generalize (refl_equal (boxinv fs));
      generalize (boxinv fs) at -1.
    induction 2; intuition; unfold In; subst; unfold boxinv; eauto 3.
  Qed.

  Axiom prime_extension : forall fs f, ~provable fs f ->
    exists fs', prime fs' /\ ~provable fs' f /\
      forall h, provable fs h -> provable fs' h.
  Axiom pr_decidable : forall fs f, provable fs f \/ ~provable fs f.

  Ltac assert_pt z x f :=
    let H := fresh in
      assert(H : prime x /\ consistent x /\ ~provable x (<> f))
        by (intuition; eauto);
        set (z := exist _ (x, f) H : W).

  Hint Unfold consistent.

  Lemma prime_lemma : forall fs f,
    (forall x : W, (forall g, provable fs g -> provable (fst (proj1_sig x)) g) ->
      provable (fst (proj1_sig x)) f) ->
    provable fs f.
    intros fs f H; assert (~~provable fs f);
      [ | case (pr_decidable fs f)]; intuition.
    destruct (prime_extension H0) as [T [? [? ?]]].
    assert_pt y T Bot.
    specialize (H y).
    auto.
    Existential 1 := Bot.
  Qed.

  Ltac destruct_iff :=
    match goal with
      [ H : forall _, _ <-> _ |- _] =>
      pose proof (fun x => proj1 (H x));
        pose proof (fun x => proj2 (H x));
          clear H
    end.

  Lemma equivalence : forall f x, provable (fst (proj1_sig x)) f <-> satisfies x f.
    induction f;
      intro x; destruct x as [T [p [con mcon]]];
        simpl in *; intuition; repeat destruct_iff.

    apply H2; eauto.

    apply H0; eauto.

    assert (provable (fst T) f1 /\ provable (fst T) f2) by firstorder.
    intuition; eauto 3.

    assert (provable (fst T) f1 \/ provable (fst T) f2) by auto; intuition.

    assert (provable (fst T) f1) by firstorder.
    eauto 3.

    assert (provable (fst T) f2) by firstorder.
    eauto.

    eauto.

    apply deduction_theorem.
    apply prime_lemma.
    auto 8 using weakening.

    destruct H1.
    eauto.

    assert (In (boxinv (fst T)) f); [| eauto].
    apply boxinv_closed.
    apply prime_lemma.
    intros.
    assert_pt x' (fst T) Bot.
    specialize (H x').
    apply H1; apply H; intuition.

    unfold R.
    intuition.

    destruct x; simpl in *; intuition.

    destruct y as [[T' g] [? [? mcon']]]; simpl in *.
    destruct (@prime_extension (Add _ (boxinv T') f) g); intuition.
    apply mcon'.
    assert (provable (boxinv T') (f '-> g))
      by auto using deduction_theorem.
    assert (provable T' ([] (f '-> g))) by
      (specialize (boxinv_closed H4); auto).
    eauto 4.

    assert_pt x1 x0 Bot.
    exists x1; intuition.
    unfold R; intuition.
    apply H1; auto.

    destruct T as [x' ?]; simpl in *.
    assert (~~provable x' (<> f)); intuition.
    assert_pt z x' f.
    destruct (H z).
    auto.

    intuition.
    destruct H5.
    subst; simpl in *; auto.

    case (pr_decidable x' (<> f)); intuition.

    Existential 1 := Bot.
    Existential 1 := Bot.
  Qed.

  Hint Resolve (fun f x => proj1 (equivalence f x)).
  Hint Resolve (fun f x => proj2 (equivalence f x)).

  Theorem completeness : forall fs f,
    (forall T, (forall g, In fs g -> satisfies T g) -> satisfies T f) ->
    provable fs f.
    auto 7 using prime_lemma.
  Qed.
End Canonical_Model_facts.