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

(**********************************************************************)
(*             Delayed Substitution Lambda Calculus                   *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation               *)
(* of Lambda Calculus  from Project Coq                               *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                      DLB_Normal.v                                  *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import General.
Require Import DLB_Terms.
Require Import DLB_Tactics.
Require Import DLB_reduction.

Inductive sort :=
  Tuple
| Index
| Term
| Funty : sort -> sort -> sort
.

Inductive well_formed : sort -> lambda -> Prop :=
| wf_un: well_formed Tuple Unit
| wf_pair:forall P M, well_formed Tuple P -> well_formed Term M -> well_formed Tuple (Pair P M)
| wf_ref: forall i M, well_formed Tuple M -> well_formed Term (Ref i M)
| wf_raise_tuple: forall M n j, well_formed Tuple M -> well_formed Tuple (Raise M n j)
| wf_raise_term: forall M n j, well_formed Term M -> well_formed Term (Raise M n j)
| wf_abs : forall j M, well_formed Term M -> well_formed Term (Abs j M)
| wf_app: forall M N, well_formed Term M -> well_formed Term N -> well_formed Term (App M N)
.

Hint Constructors well_formed.

Lemma unique_sort:
forall t s1 s2, well_formed s1 t -> well_formed s2 t -> s1 = s2.
Proof. induction t; split_all; inversion H; inversion H0; subst; auto. Qed.

Lemma dlb_red1_preserves_well_formed:
forall M N, dlb_red1 M N -> forall s, well_formed s M -> well_formed s N.
Proof.
intros M N r; induction r; split_all; try (inversion H; subst; auto; fail).
(* 9 *)
inversion H; subst; auto. eapply2 wf_ref. eapply2 wf_pair. inversion H3; auto.
(* 8 *)
inversion H; subst. inversion H2; subst. eapply2 wf_pair. inversion H2.
(* 7 *)
inversion H0; subst; inversion H3; subst. eapply2 wf_ref.
(* 6 *)
inversion H0; subst; inversion H3; subst. eapply2 wf_ref.
(* 5 *)
inversion H; subst; inversion H2; subst. eapply2 wf_abs.
(* 4 *)
inversion H0; subst. inversion H4; subst. auto.
(* 3 *)
inversion H0; subst. inversion H4; subst. auto.
(* 2 *)
inversion H; subst. inversion H3; subst.  inversion H2; subst.  inversion H5; subst.
eapply2 wf_app. eapply2 wf_app.
(* 1 *)
inversion H; subst. inversion H3; subst.  inversion H2; subst.
eapply2 wf_abs.
Qed.

Lemma dlb_red_preserves_well_formed:
forall red M N, multi_step red M N -> red = dlb_red1 ->
forall s, well_formed s M -> well_formed s N.
Proof.
intros red M N r; induction r; split_all; subst. eapply2 IHr.
eapply2 dlb_red1_preserves_well_formed.
Qed.

Fixpoint rank (M: lambda) :=
match M with
| Unit => 1
| Pair M1 M2 => S((rank M1) + (rank M2))
| Ref _ P => S (rank P)
| Raise M1 _ _ =>  S(rank M1)
| Abs _ M1 => S(rank M1)
| App M1 M2 => S((rank M1) + (rank M2))
end.

Lemma rank_positive: forall M, rank M > 0.
Proof.
induction M; split_all; try omega.
Qed.

Ltac rank_tac := match goal with
| |- forall M, ?P  =>
cut (forall p M, p >= rank M -> P ); [ intros H M;  eapply2 H |
intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
]
end .

(* normal terms *)

Inductive normal : sort -> lambda -> Prop :=
| nf_un: normal Tuple Unit
| nf_pair: forall s u,  normal Tuple s -> normal Term u -> normal Tuple (Pair s u)
| nf_ref: forall i s, normal Tuple s -> normal Term (Ref i s)
| nf_abs : forall j M, normal Term M -> normal Term (Abs j M)
.

Hint Constructors normal.

Lemma normal_is_decidable : forall M s, normal s M \/ ~(normal s M).
Proof.
induction M; intro s; case s; auto;
try (right; intro n1;  inversion n1; fail).
(* 3 *)
elim(IHM1 Tuple); elim(IHM2 Term); split_all.
right; intro n; inversion n; assert False by eapply2 H; noway.
(* 4 *)
right; intro n; inversion n; assert False by eapply2 H0; noway.
(* 3 *)
right; intro n; inversion n; assert False by eapply2 H0; noway.
(* 2 *)
elim(IHM Tuple); split_all. right; intro n1; inversion n1; assert False by eapply2 H; noway.
(* 1 *)
elim(IHM Term); split_all. right; intro n1; inversion n1; assert False by eapply2 H; noway.
Qed.

Lemma normal_implies_well_formed: forall M s, normal s M -> well_formed s M.
Proof. intros M; induction M; split_all; inversion H; auto; subst.  Qed.

Definition irreducible M (red:termred) := forall N, red M N -> False.

Lemma normal_is_irreducible:
forall s M, normal s M -> irreducible M seq_red1.
Proof.
intros s M nor; induction nor; split_all; intro; intro r; inversion r; subst; split_all.
(* 4 *)
eapply2 IHnor1.
(* 3 *)
eapply2 IHnor2.
(* 2 *)
eapply2 IHnor.
(* 1 *)
eapply2 IHnor.
Qed.

(*
The basic progress result, that all irreducible terms are normal.
 *)

Lemma beta_normal:
  forall j M N, normal Term M -> well_formed Term (App (Abs j M) N) ->
                   exists P, seq_red1 (App (Abs j M) N) P.
Proof.
  induction M; split_all; inversion H; subst; eauto.
  assert(n<j \/ n> j \/ n=j) by omega. inversion H1; subst; eauto.
inversion H3; subst; eauto. inversion H2; subst; eauto; inversion H3; subst; eauto.
Qed.

Lemma raise_normal:
  forall M, normal Term M -> forall n j, exists N, seq_red1 (Raise M n j) N.
Proof.
induction M; split_all; eauto; inversion H; subst.
cut(n < j \/ n >= j).  intro c; inversion c; eauto. omega.
Qed.

Theorem tuple_progress :
forall (M : lambda) s, well_formed s M -> (normal s M) \/ (exists N, seq_red1 M N) .
Proof.
induction M; try (inversion IHM); subst; split_all; eauto.
(* 6 *)
inversion H; subst; eauto.
(* 5 *)
inversion H; subst; eauto.
assert((normal Tuple M1) \/ (exists N : lambda, seq_red1 M1 N)).
eapply2 IHM1.
inversion H0; split_all.
assert((normal Term M2) \/ (exists N : lambda, seq_red1 M2 N)).
eapply2 IHM2.
inversion H2; split_all; subst; eauto.
right; exist (Pair x M2).
(* 4 *)
inversion H; subst.
assert(normal Tuple M \/ (exists N : lambda, seq_red1 M N)) by  eapply2 IHM.
inversion H0; split_all. right; eauto.
(* 3 *)
right. inversion H; subst.
elim(IHM Tuple); split_all.
inversion H0; subst; eauto.  eauto.
elim(IHM Term); split_all.
inversion H0; subst; eauto.
cut(i < n0 \/ i >= n0).  intro c; inversion c; eauto. omega.
eauto.
(* 2 *)
 inversion H; subst.
elim(IHM Term); split_all.
right; eauto.
(* 1 *)
right.
inversion H; subst; eauto.
elim(IHM1 Term); split_all.
inversion H0; subst; eauto.
inversion H0; subst. eapply2 beta_normal.
eauto.
Qed.

Lemma irreducible_is_normal:
forall s M, well_formed s M -> irreducible M seq_red1 -> normal s M.
Proof. split_all. elim(tuple_progress M s); split_all. assert False by eapply2 H0; noway. Qed.

Theorem irreducible_iff_normal: forall s M, well_formed s M -> (irreducible M seq_red1 <-> normal s M).
Proof. split_all. eapply2 irreducible_is_normal. eapply2 normal_is_irreducible. Qed.

Definition stable M := forall N, dlb_red M N -> N = M.

Theorem normal_implies_stable: forall s M, normal s M -> stable M.
Proof.
unfold stable; split_all.
assert(seq_red M N) by eapply2 dlb_red_to_seq_red.
inversion H1; subst. auto.
assert(irreducible M seq_red1). eapply2 irreducible_iff_normal.
eapply2 normal_implies_well_formed.
assert False by eapply2 H4. noway.
Qed.


(** * Imp: 간단한 명령형 언어 *)

(** 이 장에서 콕 밖에 있는 흥미로운 것을 콕으로 공부하는 방법을 더
    진지하게 살펴볼 것이다. 우리의 사례 연구는 C와 Java와 같은 보통의
    주류 언어의 작은 핵심 부분을 포함하는 _간단한 명령형 프로그래밍
    언어_로 Imp라 부른다. 여기 잘 알고 있는 수학 함수를 Imp로
    작성해본다.

     Z ::= X;; Y ::= 1;; WHILE not (Z = 0) DO Y ::= Y * Z;; Z ::= Z -
     1 END *)

(** 이 장에서 Imp의 _구문_과 _의미_를 정의하는 법을
    살펴본다. _프로그래밍언어 기초_의 추가 장들에서 (_소프트웨어
    기초_, 2권) _프로그램 동치_ 이론을 제시하고, 명령형 프로그램을
    추론하는데 널리 사용하는 논리 _호어 논리_를 소개한다. *)

Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.
Import ListNotations.

From LF Require Import Maps.

(* ################################################################# *)
(** * 산술식과 부울식 *)

(** Imp를 세가지 부분으로 나누어 소개한다. 우선 _산술식과 부울식_의
    핵심 언어 그 다음 _변수_를 도입하여 확장하고 마지막으로 할당문,
    조건문, 순차문, 반복문을 포함한 _명령어_ 언어 부분으로 나눈다. *)

(* ================================================================= *)
(** ** 구문 *)

Module AExp.

(** 아래 두 정의는 산술식과 부울식의 _추상 구문_을 규정한다. *)

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

(** 이 장에서 프로그래머가 실제로 작성하는 실제 구문에서 이 추상 구문
    트리로 변환하는 것을 생략할 것이다. 이 과정은 예를 들어 문자열
    ["1+2*3"]을 다음 AST로

      APlus (ANum 1) (AMult (ANum 2) (ANum 3)).

    변환할 것이다.

    선택 사항인 [ImpParser]장에서 이러한 변환을 할 수 있는 간단한 어휘
    분석과 구문 분석 구현한다. 이 구현 방법을 이해학 위해서 해당 장을
    이해할 필요는 _없다_. 하지만 이 기법을 다루는 강의를 듣지 않았다면
    (예: 컴파일러 과목) 자세히 읽지 않아도 된다. *)

(** 비교를 위해 여기 동일한 추상 구문을 정의하는
    전통적인 BNF (Backus-Naur Form) 문법이 있다.

    a ::= nat
        | a + a
        | a - a
        | a * a

    b ::= true
        | false
        | a = a
        | a <= a
        | not b
        | b and b
*)

(** 위의 콕 버전과 비교하면...

       - 이 BNF는 더 비형식적이다. 예를 들어 식의 표면적인 구문이 약간
         남아 있다. 덧셈 연산은 [+]으로 작성하고 중위 기호라는 것을 알
         수 있지만 어휘 분석과 구문 분석의 다른 면은 생략하고
         있다. 예를 들어 [+], [-], [*]의 상대적인 우선순위는 표현되어
         있지 않다. 컴파일러를 구현할 때와 같이 이 구문을 형식적인
         정의로 바꾸려면 추가적인 정보(와 인간 지능)이 필요할 수 있다.

         콕 버전은 일관되게 이런 모든 정보를 생략하고 추상 구문에만
         집중한다.

       - 반면에 BNF 버전은 더 간단하고 읽기 쉽다. 이 버전의 비형식적인
         면은 표현이 유연하고, 일반적인 아이디어를 전달하는 것이 모든
         상세한 내용을 정밀하게 정의하는 것 보다 중요한 칠판에서
         토의와 같은 상황에서 큰 장점이 있다.

         정말로 BNF 같은 표기법이 십여개 있고 이 표기법을 자유롭게
         바꾸어 사용한다.  사용하는 BNF 형식이 무엇인지 말하지 않는데
         그럴 필요도 없기 때문이다. 대강 준비된 비형식적으로 이해하는
         것이 바로 중요한 것이다.

    두 가지 종류의 표기법, 즉 사람과 얘기할 때 비형식적인 표기법을,
    구현하고 증명할 때 형식적인 표기법에 편해지는 것이 좋다. *)

(* ================================================================= *)
(** ** 계산 *)

(** 산술식을 _계산_하여 숫자를 낸다. *)

Fixpoint aeval (a : aexp) : nat :=
  match a with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2  => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

Example test_aeval1:
  aeval (APlus (ANum 2) (ANum 2)) = 4.
Proof. reflexivity. Qed.

(** 비슷하게 부울식을 계산하면 부울값을 얻는다. *)

Fixpoint beval (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval a1) (aeval a2)
  | BLe a1 a2   => leb (aeval a1) (aeval a2)
  | BNot b1     => negb (beval b1)
  | BAnd b1 b2  => andb (beval b1) (beval b2)
  end.

(* ================================================================= *)
(** ** 최적화 *)

(** 아직 그다지 많이 정의하지 않았지만 벌써 이 정의들을 이용할 수
    있다.  산술식을 취해서 [0+e]가 나타나면 [e]로 간략화하는 함수를
    가정하자 (예를 들어, [(APlus (ANum 9) e])을 [e]로). *)

Fixpoint optimize_0plus (a:aexp) : aexp :=
  match a with
  | ANum n =>
      ANum n
  | APlus (ANum 0) e2 =>
      optimize_0plus e2
  | APlus e1 e2 =>
      APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

(** 이 최적화 방법이 올바른지 몇가지 예제를 가지고 테스트해서 그
    결과가 OK인지 볼 수 있다. *)

Example test_optimize_0plus:
  optimize_0plus (APlus (ANum 2)
                        (APlus (ANum 0)
                               (APlus (ANum 0) (ANum 1))))
  = APlus (ANum 2) (ANum 1).
Proof. reflexivity. Qed.

(** 이 최적화가 정확한지 (즉, 최적화된 식을 계산하면 원래 식과 동일한
    결과를 내는지)를 확신하고 싶으면 증명해야 한다. *)

Theorem optimize_0plus_sound: forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a. induction a.
  - (* ANum *) reflexivity.
  - (* APlus *) destruct a1.
    + (* a1 = ANum n *) destruct n.
      * (* n = 0 *)  simpl. apply IHa2.
      * (* n <> 0 *) simpl. rewrite IHa2. reflexivity.
    + (* a1 = APlus a1_1 a1_2 *)
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    + (* a1 = AMinus a1_1 a1_2 *)
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    + (* a1 = AMult a1_1 a1_2 *)
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
  - (* AMinus *)
    simpl. rewrite IHa1. rewrite IHa2. reflexivity.
  - (* AMult *)
    simpl. rewrite IHa1. rewrite IHa2. reflexivity.  Qed.

(* ################################################################# *)
(** * 콕 자동화 *)

(** 위 증명에서 조금 짜증나는 수준으로 반복되는 패턴이
    나타난다. 산술식 언어나 증명하려는 최적화가 상당히 더 복잡하다면
    정말 큰 문제가 될 것이다.

    이제까지 적은 수의 콕 전술만 사용해서 증명해왔다. 증명의 일부를
    자동으로 만들어내는 강력한 기능을 완전히 무시했다. 이 절에서 이런
    기능들을 몇 가지 소개하고 다음 장들에서 더 보게 될 것이다.  콕의
    자동화는 강력한 도구이고 이 자동 증명 기능에 익숙해지려면 노력이
    필요하다. 하지만 일단 익숙해지면 우리의 능력을 확장시켜서 더
    복잡한 정의와 더 흥미로운 성질들까지 지루하거나 반복적이거나
    상세한 내용에 압도되지 않고 증명하도록 만들 것이다. *)

(* ================================================================= *)
(** ** 고차원 전술(Tacticals) *)

(** _고차원 전술_은 다른 전술을 인자로 받는 전술에 대한 콕 용어다.  *)

(* ----------------------------------------------------------------- *)
(** *** [try] 고차원 전술 *)

(** 만일 [T]가 전술이면 [try T]는 [T]처럼 동작하는 전술로 한가지
    예외는 [T]가 실패하면 [try T]는 (실패하는 대신) _성공적으로_ 전혀
    아무것도 하지 않는다. *)

Theorem silly1 : forall ae, aeval ae = aeval ae.
Proof. try reflexivity. (* this just does [reflexivity] *) Qed.

Theorem silly2 : forall (P : Prop), P -> P.
Proof.
  intros P HP.
  try reflexivity. (* [reflexivity]만 실패할 것이다. *)
  apply HP. (* 다른 방법으로 이 증명을 여전히 마무리지을 수 있을 것이다. *)
Qed.

(** 위와 같은 모두 수동 증명인 경우에 [try]를 사용할 이유가 없지만
    다음에 보게 되듯이, [;] 고차원 전술과 함께 증명을 자동화하는 것이
    매우 유용하다. *)

(* ----------------------------------------------------------------- *)
(** *** [;] 고차원 전술 (간단한 형태) *)

(** 가장 흔한 형태로 [;] 고차원 전술은 두 전술을 인자로 받는다. 복합
    전술 [T; T']은 먼저 [T]를 실행하고 [T]에 의해 생성된 _각 부분
    목적_에 그 다음 [T']을 실행한다. *)

(** 예를 들어, 다음 간단한 보조 정리를 보자. *)

Lemma foo : forall n, leb 0 n = true.
Proof.
  intros.
  destruct n.
    (* 동일하게 증명될 두 부분 목적을 남긴다...  *)
    - (* n=0 *) simpl. reflexivity.
    - (* n=Sn' *) simpl. reflexivity.
Qed.

(** 이 증명을 [;] 고차원 전술을 사용하여 간단하게 만들 수 있다. *)

Lemma foo' : forall n, leb 0 n = true.
Proof.
  intros.
  (* 현재 목적을 [destruct] *)
  destruct n;
  (* 그 다음 생성된 각 부분 목적을 [simpl]  *)
  simpl;
  (* 그리고 생성된 부분 목적에 [reflexivity]을 적용 *)
  reflexivity.
Qed.

(** [try]와 [;]를 함께 사용하여 조금 전에 반복되는 패턴이 나타나
    증명하기 귀찮았던 증명에서 이 반복 패턴을 제거할 수 있다. *)

Theorem optimize_0plus_sound': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;
    (* 대부분의 경우 IH로 증명하고... *)
    try (simpl; rewrite IHa1; rewrite IHa2; reflexivity).
    (* ... 남은 경우 ANum과 APlus는 다르다. *)
  - (* ANum *) reflexivity.
  - (* APlus *)
    destruct a1;
      (* 다시 한번 대부분의 경우 IH로 증명하고 *)
      try (simpl; simpl in IHa1; rewrite IHa1;
           rewrite IHa2; reflexivity).
    (* 흥미로운 경우는 [e1 = ANum n]일 때인데 [try...]가 아무 효과가
       없다. 이 경우 [n]을 생성자 별로 나누어 최적화가 적용가능한지 보고
       귀납적 가정을 가지고 부분 목적을 다시 작성해서 변형해야 한다.  *)
    + (* a1 = ANum n *) destruct n;
      simpl; rewrite IHa2; reflexivity.   Qed.

(** 콕 전문가는 [induction]같은 전술 다음에 많은 유사한 경우를 한번에
    다 증명하기 위해 "[...; try...]"와 같은 관용 표현을 자주 사용한다.
    자연스럽게 비형식적 증명에서도 이런 행위와 비슷한 것이 있다. 예를
    들어, 최적화 정리에 대한 형식적 증명의 구조와 일치하는 비형식적
    증명이 여기 있다.

    _정리_: 모든 산술식 [a]에 대하여,

       aeval (optimize_0plus a) = aeval a.

    _증명_: [a]에 대한 귀납법에 의하여, 대부분의 경우 IH에 의해
    증명한다. 남은 경우는 다음과 같다.

      - 어떤 [n]에 대해 [a = ANum n]를 가정하자. 다음을 보여야 한다:

          aeval (optimize_0plus (ANum n)) = aeval (ANum n).

        [optimize_0plus]의 정의로부터 바로 증명 가능하다.

      - 어떤 [a1]과 [a2]에 대해 [a = APlus a1 a2]를 가정하자. 다음을
        보여야 한다:

          aeval (optimize_0plus (APlus a1 a2)) = aeval (APlus a1 a2).

        [a1]의 가능한 형태들을 살펴보자. 대부분의 경우
        [optimize_0plus]는 부분식을 가지고 재귀적으로 자기 자신을
        호출할 뿐이고 [a1]과 동일한 형태의 새로운 식을 다시 만든다. 이러한
        경우 IH에 의해 바로 증명할 수 있다.

        흥미로운 경우는 어떤 [n]에 대해 [a1 = ANum n]일 때이다. 만일 [n = 0]이면

          optimize_0plus (APlus a1 a2) = optimize_0plus a2

        그리고 [a2]에 대한 IH는 정확히 우리가 필요한 것이다. 반면에 어떤 [n']에 대해
        [n = S n']이라면 다시 [optimize_0plus]는 재귀적으로 자기 자신을
        호출할 뿐이고 그 결과는 IH에 의해 증명된다. [] *)

(** 하지만 이 증명은 여전히 개선될 여지가 있다. (a = ANum n)인 첫번째
    경우 매우 간단하다. 언급했던 IH를 따를 뿐인 경우들보다 훨씬 더
    간단하다. 하지만 이 증명을 상세하게 작성하기로 결정했다. 아마도
    처음부터 이러한 상세 증명을 버리고 "대부분의 경우 IH로부터 바로
    또는 직접적으로 증명가능하다. 오직 흥미로운 경우는 [APlus]에 대한
    경우이다..."고 언급만 한다면 더 좋고 명확한 증명이 될 것이다.
    우리의 형식적 증명에서도 동일하게 개선할 수 있다. 이러한 내용을
    여기에서 설명한다. *)

Theorem optimize_0plus_sound'': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;
    (* 대부분의 경우 IH에 의해 직접 증명 가능하거나 *)
    try (simpl; rewrite IHa1; rewrite IHa2; reflexivity);
    (* ... 또는 정의에 의해 바로 증명 가능하다 *)
    try reflexivity.
  (* 흥미로운 경우는 a = APlus a1 a2일 때이다. *)
  - (* APlus *)
    destruct a1; try (simpl; simpl in IHa1; rewrite IHa1;
                      rewrite IHa2; reflexivity).
    + (* a1 = ANum n *) destruct n;
      simpl; rewrite IHa2; reflexivity. Qed.

(* ----------------------------------------------------------------- *)
(** *** [;] 고차원 전술 (일반적인 형태) *)

(** [;] 고차원 전술도 위에서 살펴본 [T;T']보더 더 일반적인 형태를 갖는다.
    주어진 전술 [T], [T1], ..., [Tn]에 대해

      T; [T1 | T2 | ... | Tn]

    는 [T]를 먼저 실행한 다음 [T]로 생성한 첫번째 부분 목적에 [T1]을 실행하고
    두번째 부분 목적에 [T2]를 실행하고, 등등.

    그래서 [T;T']는 모든 [Ti]가 동일한 전술인 경우를 위한 특별한 표기법일 뿐이다.
    즉, [T;T']는 다음 표현의 축약형이다:

      T; [T' | T' | ... | T']
*)

(* ----------------------------------------------------------------- *)
(** *** [repeat] 고차원 전술 *)

(** [repeat] 고차원 전술은 다른 전술을 받아 반복해서 적용하다 전술
    적용이 실패하면 멈춘다. 다음은 repeat를 사용하여 긴 리스트에
    [10]이 포함되어 있는지 보여주는 예제이다. *)

Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (try (left; reflexivity); right).
Qed.

(** [repeat T] 전술은 결코 실패하지 않는다. 만일 전술 [T]가 원래
    목적에 적용되지 않으면 repeat는 여전히 성공한 것으로 간주하되 원래
    목적을 변경하지 않는다. 즉, 0번 반복한다. *)

Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (left; reflexivity).
  repeat (right; try (left; reflexivity)).
Qed.

(** 전술 [repeat T]도 [T]를 적용하는 횟수에 어떠한 상한선도 없다. 항상
    성공하는 전술 [T]라면 영원 반복할 것이다. 예를 들어, [simpl]은
    항상 성공하기 때문에 [repeat simpl]은 영원히 반복한다. 콕 언어
    Gallina에서 모든 계산은 종료하는 것이 보장되는 반면 전술을 적용할
    때의 계산은 그렇지 않다! [repeat]와 다른 전술이 하는 일은 콕으로
    하여금 증명을 만드는 것을 가이드하는 것이기 때문에 전술의 비종료
    가능성으로 콕의 논리적 일관성이 지켜지지 않는 영향을 주지 않는다.
    증명을 만드는 과정이 무한히 끝나지 않으면 이것은 단지 증명을
    만드는데 실패했다는 것을 뜻하지 잘못된 증명을 만들었다는 것은
    아니다. *)

(** **** 연습문제: 별 세 개 (optimize_0plus_b)  *)
(** [optimize_0plus] 변환은 [aexp] 값을 변경하지 않기 때문에 [bexp]의
    값을 변경하지 않고 [bexp]에 나타난 모든 [aexp]에 적용할 수 있어야
    한다. [bexp]에 대한 변환을 실행하는 함수를 작성하고 이 변환이
    건전함을 증명하시오.  우리가 살펴본 고차원 전술만 사용해서 이
    증명을 최대한 우아하게 만들어보시오. *)

Fixpoint optimize_0plus_b (b : bexp) : bexp
  (* 이 줄을 당신의 정의로 바꾸시오 *). Admitted.

Theorem optimize_0plus_b_sound : forall b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 네 개, 선택사항 (optimizer)  *)
(** _설계 연습문제_: [optimize_0plus] 함수로 구현한 최적화는 산술식과
    부울식에 관한 많은 방법들 중 한가지일뿐이다.  더 복잡한 최적화를
    작성하고 정확성을 증명해보시오. 작은 것부터 시작해서 (한가지 간단한 최적화를 추가해서
    정확성을 증명하기) 점차 더 흥미로운 것을 쌓아보는 것이 가장 쉬울 것이다.

(* 여기를 채우시오 *) *)
(** [] *)

(* ================================================================= *)
(** ** 새로운 전술 표기법을 정의하기 *)

(** 콕은 전술 스크립트를 "프로그래밍"하는 여러가지 방법도 제공한다.

    - 아래에 예시로 든 [Tactic Notation] 관용어는 여러 전술들을 하나의
      명령어로 묶는 "축약된 전술"을 정의하는 쉬운 방법이다.

    - 더 복잡한 프로그래밍을 위해서 콕은 [Ltac]이라 부르는 내장된
      언어를 제공하고 이 언어에 포함된 기본 연산들로 증명 상태를
      살펴보고 수정할 수 있다. 상세한 내용은 꽤 너무 복잡해서 여기에서
      다룰 수 없다 (그리고 [Ltac]은 콕 설계에서 가장 아름다운 부분은
      아니라고 일반적으로 생각한다!). 하지만 참고 매뉴얼과 콕에 관한
      다른 책에서 [LTac]의 상세 내용을 확인할 수 있다. 콕 표준
      라이브러리에 [Ltac] 정의의 많은 예가 있고 예로 사용할 수 있다.

    - OCaml API도 있어서 낮은 수준에서 콕 내부 구조를 접근하는 전술을
      만들때 사용할 수 있다. 하지만 일반 콕 사용자를 위해서는 이
      어려움을 극복할만한 가치가 거의 없다.

    [Tactic Notation]은 전술을 정의하는 가장 쉬운 방법이다. 다양한
    목적을 위해 많은 기능을 제공한다. 여기 예가 있다. *)

Tactic Notation "simpl_and_try" tactic(c) :=
  simpl;
  try c.

(** [simpl_and_try]라 부르는 새로운 고차원 전술을 정의한다. 전술 [c]를
    인자로 받고 [simpl; try c] 전술과 똑같이 동작하도록 정의한다.
    이제 "[simpl_and_try reflexivity.]"를 쓰면 증명에서 "simpl; try
    reflexivity.]"처럼 동작할 것이다.  *)

(* ================================================================= *)
(** ** [omega] 전술 *)

(** [omega] 전술은 _Presburger arithmetic_이라 부르는 1차 논리 일부에
    대한 판단 절차를 구현한다. Willaim Pugh [Pugh 1991]에 의해 1991년
    발명한 오메가 알고리즘에 기초한다.

    목적이 보편적인 한정사로 한정된 식이고 다음 요소로 구성되어 있다면

     - 숫자 상수, 덧셈 ([+]와 [S]), 뺄셈 ([-]와 [pred]), 상수 곱셈 (이
       것이 프레스버거 산술식이다),

     - 등식 ([=]과 [<>])과 순서 ([<=])와

     - 논리 연결자 [/\], [\/], [~], and [->],

    [omega]를 실행하면 이 목적을 풀거나 또는 사실 거짓이라고 답해줄
    것이다. *)

Example silly_presburger_example : forall m n o p,
  m + n <= n + o /\ o + 3 = p + 3 ->
  m <= p.
Proof.
  intros. omega.
Qed.

(** (파일 시작 부분에 [Require Import Coq.omega.Omega.]를 보시오. *)

(* ================================================================= *)
(** ** 두세 가지 편리한 전술들 *)

(** 마지막으로 편리한 몇 가지 기타 전술이 있다.

     - [clear H]: 문맥에서 가정 [H]를 삭제.

     - [subst x]: [x = e]나 [e = x] 가정을 문맥에서 찾아 문맥과 현재
       목적에서 [x]를 [e]로 대체하고 가정을 지운다.

     - [subst]: [x = e]나 [e = x] 형태의 _모든_ 가정을 대체한다.

     - [rename... into...]: 증명 문맥에서 가정의 이름을 변경한다.
       예를 들어 이 문맥에 변수 [x]가 있으면 [rename x into y]는 [x]가
       나타난 곳에을 모두 [y]로 변경할 것이다.

     - [assumption]: 목적과 정확히 매치되는 문맥에서 가정 [H]를 찾도록
       시도한다.  만일 찾으면 [apply H]와 같이 동작한다.

     - [contradiction]: [False]와 논리적으로 동치인 현재 문맥에서 가정
       [H]를 찾으리려고 시도한다. 만일 그러한 가정을 찾으면 목적을
       증명한다.

     - [constructor]: 현재 목적을 증명하는데 적용할 수 있는 (현재
       환경에서 어떤 [Inductive] 정의로부터) 생성자 [c]를 찾도록 시도하자.
       만일 찾으면 [apply c]처럼 동작하시오.

    진행하면서 예제들을 살펴볼 것이다. *)

(* ################################################################# *)
(** * 관계로 계산을 정의하기 *)

(** [aeval]과 [beval]을 [Fixpoints]로 정의한 함수로 제시하였다.
    계산에 대해 생각하는 다른 방법은 식과 값 사이의 _관계_이다.  종종
    더 유연한 방법이라는 것을 알게 될 것이다. 이 방법은 산술식에 대한
    다음 정의와 같이 자연스럽게 [Inductive] 정의를 사용한다... *)

Module aevalR_first_try.

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum  : forall (n: nat),
      aevalR (ANum n) n
  | E_APlus : forall (e1 e2: aexp) (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus: forall (e1 e2: aexp) (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult : forall (e1 e2: aexp) (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMult e1 e2) (n1 * n2).

(** [aevalR]을 중위 표기법으로 표현하는 것은 편리할 것이다.  [e \\
    n]이라 작성하여 산술식 [e]를 값 [n]으로 계산하는 것을 의미한다. *)

Notation "e '\\' n"
         := (aevalR e n)
            (at level 50, left associativity)
         : type_scope.

End aevalR_first_try.

(** 사실, 콕은 [aevalR] 자체의 정의에서 이 표기법을 사용하는 방법을
    제공한다.  [e \\ n] 형태의 문장을 포함하는 증명에 관하여 작업하고
    있는 상황을 피해서 혼란을 줄이되, [aevalR e n]를 사용하여 작성한
    정의를 참조해야 한다.

    이 표기법을 먼저 "예약"하고 그 다음 표기법의 의미를 선언하여 정의한다. *)

Reserved Notation "e '\\' n" (at level 50, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n:nat),
      (ANum n) \\ n
  | E_APlus : forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus : forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult :  forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)

  where "e '\\' n" := (aevalR e n) : type_scope.

(* ================================================================= *)
(** ** 추론 규칙 표기법 *)

(** 비형식적 논의에서 [aevalR]과 유사한 관계를 더 보기 좋은 _추론
    규칙_의 그래픽 형태로 규칙을 작성하는 것이 편리하다. 줄 위의
    가설에서 아래의 결론을 추론한다 ([IndProp] 장에서 추론 규칙들을
    이미 보았다).  *)

(** 예를 들어, 생성자 [E_APlus]는...

      | E_APlus : forall (e1 e2: aexp) (n1 n2: nat),
          aevalR e1 n1 ->
          aevalR e2 n2 ->
          aevalR (APlus e1 e2) (n1 + n2)

    ...추론 규칙으로 아래와 같이 작성할 것이다:

                               e1 \\ n1
                               e2 \\ n2
                         --------------------                         (E_APlus)
                         APlus e1 e2 \\ n1+n2
*)

(** 형식적으로, 추론 규칙에 대해 깊이 설명할 내용이 없다. 추론 규칙은
    함축일뿐이다.  오른쪽에 규칙 이름을 생성자 이름으로 읽고 추론 규칙
    줄 위의 각 줄의 전제를 [->] 함축으로 읽을 수 있다. 규칙에 언급된
    모든 변수들 ([e1], [n1], 등)은 맨 앞에 전체 한정사에 묵시적으로
    한정된다. (그런 변수들을 _메타 변수_라고 부르고 우리가 정의하는
    언어의 변수와 구분한다. 당분간 산술식은 변수를 포함하지 않지만 곧
    더할 것이다.) 모든 규칙을 모아놓은 것을 [Inductive] 선언으로 감싼
    것으로 표현한다. 규칙 전체에 대한 설명은 비형식적으로 서술할 때
    생략하거나 "[aevalR]은 다음 규칙하에 닫힌 가장 작은 관계라 하자"와
    같이 말한다. *)

(** 예를 들어, [\\]는 이 규칙들로 닫힌 가장 작은 관계다.

                             -----------                               (E_ANum)
                             ANum n \\ n

                               e1 \\ n1
                               e2 \\ n2
                         --------------------                         (E_APlus)
                         APlus e1 e2 \\ n1+n2

                               e1 \\ n1
                               e2 \\ n2
                        ---------------------                        (E_AMinus)
                        AMinus e1 e2 \\ n1-n2

                               e1 \\ n1
                               e2 \\ n2
                         --------------------                         (E_AMult)
                         AMult e1 e2 \\ n1*n2
*)

(* ================================================================= *)
(** ** 정의들 간의 동치 *)

(** 계산을 관계로 정의한 것과 함수로 정의한 것이 일치하는 것을
    증명하는 것은 간단하다. *)

Theorem aeval_iff_aevalR : forall a n,
  (a \\ n) <-> aeval a = n.
Proof.
 split.
 - (* -> *)
   intros H.
   induction H; simpl.
   + (* E_ANum *)
     reflexivity.
   + (* E_APlus *)
     rewrite IHaevalR1.  rewrite IHaevalR2.  reflexivity.
   + (* E_AMinus *)
     rewrite IHaevalR1.  rewrite IHaevalR2.  reflexivity.
   + (* E_AMult *)
     rewrite IHaevalR1.  rewrite IHaevalR2.  reflexivity.
 - (* <- *)
   generalize dependent n.
   induction a;
      simpl; intros; subst.
   + (* ANum *)
     apply E_ANum.
   + (* APlus *)
     apply E_APlus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
   + (* AMinus *)
     apply E_AMinus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
   + (* AMult *)
     apply E_AMult.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
Qed.

(** 고차원 전술을 더 사용하면 꽤 조금 더 짧게 증명할 수 있다. *)

Theorem aeval_iff_aevalR' : forall a n,
  (a \\ n) <-> aeval a = n.
Proof.
  (* 수업에서 다루었다 *)
  split.
  - (* -> *)
    intros H; induction H; subst; reflexivity.
  - (* <- *)
    generalize dependent n.
    induction a; simpl; intros; subst; constructor;
       try apply IHa1; try apply IHa2; reflexivity.
Qed.

(** **** 연습문제: 별 세 개  (bevalR)  *)
(** [aevalR]과 동일한 스타일로 [bevalR] 관계를 작성하고 [beval]과
    동치임을 증명하시오. *)

Inductive bevalR: bexp -> bool -> Prop :=
(* 여기를 채우시오 *)
.

Lemma beval_iff_bevalR : forall b bv,
  bevalR b bv <-> beval b = bv.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

End AExp.

(* ================================================================= *)
(** ** 계산 기반 vs. 관계 기반 정의 *)

(** 산술식과 부울식 계산을 정의할 때 함수 정의를 사용할 지 관계 정의를
    사용할 지 선택하는 것은 주로 취향 문제이다. 둘 다 동작한다.

    하지만 계산에 대한 함수 정의 보다 관계형 정의가 훨씬 좋은 상황이
    있다. *)

Module aevalR_division.

(** 예를 들어, 산술 연산을 확장해서 나눗셈 연산도 고려한다고 가정하자.*)

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp
  | ADiv : aexp -> aexp -> aexp.   (* <--- new *)

(** [aeval] 정의를 확장하여 이 새로운 연산을 처리하는 것은 간단하지
    않을 수 있다 ([ADiv (ANum 5) (ANum 0)]의 결과는 무엇이어야
    하는가?). 하지만 [aevalR]을 확장하는 것은 쉽다. *)

Reserved Notation "e '\\' n"
                  (at level 50, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n:nat),
      (ANum n) \\ n
  | E_APlus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult :  forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2)
  | E_ADiv :  forall (a1 a2: aexp) (n1 n2 n3: nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (n2 > 0) ->
      (mult n2 n3 = n1) -> (ADiv a1 a2) \\ n3

where "a '\\' n" := (aevalR a n) : type_scope.

End aevalR_division.

Module aevalR_extended.

(** 비결정적 숫자 생성 연산 [any]를 산술식에 추가하고 싶다고
    가정하자. 이 연산을 계산하면 임의의 숫자를 만들어낸다. (모든
    가능한 숫자들 중 _확률적_으로 선택하는 것과 동일하지 않음을
    주목하시오. 결과에 대한 어떤 특정 분포를 규정하지 않지만 어떤
    결과가 _가능한지_ 말하고 있을 뿐이다.) *)

Reserved Notation "e '\\' n" (at level 50, left associativity).

Inductive aexp : Type :=
  | AAny  : aexp                   (* <--- NEW *)
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

(** 다시 한 번 [aeval]을 확장하는 것은 약간 까다로울수 있다. 왜냐하면
    계산은 식에서 숫자로 가는 결정적 함수가 _아니기_ 때문이다. 하지만
    [aevalR]을 확장하는 것은 아무 문제가 없다. *)

Inductive aevalR : aexp -> nat -> Prop :=
  | E_Any : forall (n:nat),
      AAny \\ n                 (* <--- new *)
  | E_ANum : forall (n:nat),
      (ANum n) \\ n
  | E_APlus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult :  forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2)

where "a '\\' n" := (aevalR a n) : type_scope.

End aevalR_extended.

(** 이 시점에서 의아해할 수 있다. 기본적으로 어떤 스타일을 사용해야
    하는가?  위 예제는 관계형 정의가 근본적으로 함수형 정의보다 더
    강력하다는 것을 보여준다. 함수로 표현하기 쉽지 않거나 정말로
    함수가 _아닌_ 이와 같은 상황을 위하여 선택할 여지가 없다.  하지만
    두 가지 스타일이 모두 가능한 경우는 어떠한가?

    관계형 정의를 선호하는 한 가지는 더 우아하고 이해학 쉽다고
    생각하기 때문이다.  다른 이유는 콕은 자동으로 [Inductive]
    정의로부터 좋은 인버전과 귀납적 원리를 생성하기 때문이다.

    반면에 함수형 정의가 종종 더 편리할 수 있다. 함수는 그 자체로
    결정적이고 모든 인자에 대해 정의되어 있다. 관계형 정의에서는 이
    성질들이 필요하면 명시적으로 증명해야 한다. 함수로 정의하면 콕의
    계산 방법을 이용하여 증명동안 식을 간단하게 만들 수도 있다.

    더우기 함수는 OCaml이나 Haskell로 실행가능한 코드를 직접 "추출"할
    수 있다.

    궁극적으로 이 선택은 특정 상황의 상세한 특징이나 단순히 취향에
    달려있곤 하다.  정말로 대규모 콕 개발에서 함수와 관계 스타일
    _둘다_ 정의하고 이 두 스타일이 일치함을 보이는 보조 정리를 두어
    양쪽 관점에서 스위치하면서 증명하는 상황을 흔하게 본다. *)

(* ################################################################# *)
(** * 변수를 포함하는 식 *)

(** 다시 Imp를 정의하는 문제로 돌아가보자. 다음에 할 일은 산술식과
    부울식에 변수를 추가하는 것이다. 간단하게 유지하기 위해서 모두
    전역 변수이고 변수에 숫자만 담을 수 있다고 가정할 것이다. *)

(* ================================================================= *)
(** ** 상태 *)

(** Imp 변수 타입에 대해 [Maps] 장에서 설명한 [id] 타입을 사용할
    것이다. 왜냐하면 변수를 들여다보고 현재 값을 찾아내야 하기
    때문이다.

    _기계 상태_ (또는 그냥 _상태_)는 프로그램 실행 중 어떤 지점에서
    _모든_ 변수의 현재 값을 표현한다. *)

(** 간단하게 하기 위해서, 주어진 프로그램은 유한한 수의 변수들을
    사용하지만 상태는 _모든_ 변수를 정의한다고 가정한다. 상태는
    메모리에 저장된 모든 정보를 담는다. Imp 프로그램의 각 변수에
    자연수를 저장하기 때문에 상태를 식별자에서 [nat]로의 매핑으로
    상태를 표현할 수 있다. 더 복잡한 프로그래밍언어의 경우 더 복잡한
    구조의 상태를 두어야 할 것이다. *)

Definition state := total_map nat.

Definition empty_state : state :=
  t_empty 0.

(* ================================================================= *)
(** ** 구문  *)

(** 이전 산술식에 생성자를 하나 더 간단히 추가하여 변수를 추가할 수
있다. *)

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp                (* <----- NEW *)
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

(** 두세 가지 변수 이름을 정의해서 축약된 표기법으로 사용한다. 나중에
    예제를 쉽게 읽을 수 있도록 한다. *)

Definition W : id := Id "W".
Definition X : id := Id "X".
Definition Y : id := Id "Y".
Definition Z : id := Id "Z".

(** 프로그램 변수 이름짓는 약속 ([X], [Y], [Z]은 타입을 대문자로
    사용하던 것과 조금 충돌난다. Imp에 관한 장들에서 다형성을 많이
    사용하지 않기 때문에 오버로딩으로 혼동스럽지 않을 것이다.) *)

(** [bexp]의 정의는 그대로 둔다 (새로운 [aexp]를 사용하는 것만
    제외하고).  *)

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

(* ================================================================= *)
(** ** 계산 *)

(** 산술식과 부울식 계산기를 변수를 처리하도록 상태를 추가 인자로 받는
    명백한 방식으로 확장한다. *)

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x                                (* <----- NEW *)
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => leb (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Example aexp1 :
  aeval (t_update empty_state X 5)
        (APlus (ANum 3) (AMult (AId X) (ANum 2)))
  = 13.
Proof. reflexivity. Qed.

Example bexp1 :
  beval (t_update empty_state X 5)
        (BAnd BTrue (BNot (BLe (AId X) (ANum 4))))
  = true.
Proof. reflexivity. Qed.

(* ################################################################# *)
(** * 명령어 *)

(** Imp _명령어_의 구문(_문장_이라고 부르기도 한다)과 동작을 정의할
    준비가 이제 되었다. *)

(* ================================================================= *)
(** ** 구문 *)

(** 비형식적으로 명령어 [c]는 다음 BNF 문법으로 기술한다. (콕 표기법 방법을 사용하여
    Imp 구문을 정의할 수 있도록 다소 어색한 구체적인 구문을 선택한다. 특히 [IFB]를
    사용하여 표준 라이브러리 [if] 표기법과 충돌하지 않도록 피한다.)

     c ::= SKIP | x ::= a | c ;; c | IFB b THEN c ELSE c FI
         | WHILE b DO c END
*)
(**
    예를 들어, Imp로 작성한 팩토리얼 프로그램이다.

     Z ::= X;;
     Y ::= 1;;
     WHILE not (Z = 0) DO
       Y ::= Y * Z;;
       Z ::= Z - 1
     END

   이 명령어가 종료하면 변수 [Y]는 초기값 [X]의 팩토리얼을 포함할 것이다. *)

(** 다음은 명령어의 추상 구문의 형식적인 정의다. *)

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

(** 대개 그러하듯이 두세 가지 [Notation] 선언을 사용하여 가독성을 높일
    수 있다.  콕의 내장된 표기법과 충돌나지 않도록 가볍게 구문을
    유지한다. 특히 이미 저의한 숫자 연산자와 부울 연산자와 혼동을
    피하기 위해 [aexps]와 [bexps]에 대한 표기법은 도입하지 않는다.  *)

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

(** 예를 들어, 여기 다시 콕의 형식적인 정의로 표현한 팩토리얼 함수가
    있다. *)

Definition fact_in_coq : com :=
  Z ::= AId X;;
  Y ::= ANum 1;;
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    Y ::= AMult (AId Y) (AId Z);;
    Z ::= AMinus (AId Z) (ANum 1)
  END.

(* ================================================================= *)
(** ** 더 많은 예제들 *)

(** 할당문: *)

Definition plus2 : com :=
  X ::= (APlus (AId X) (ANum 2)).

Definition XtimesYinZ : com :=
  Z ::= (AMult (AId X) (AId Y)).

Definition subtract_slowly_body : com :=
  Z ::= AMinus (AId Z) (ANum 1) ;;
  X ::= AMinus (AId X) (ANum 1).

(* ----------------------------------------------------------------- *)
(** *** 반복문 *)

Definition subtract_slowly : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    subtract_slowly_body
  END.

Definition subtract_3_from_5_slowly : com :=
  X ::= ANum 3 ;;
  Z ::= ANum 5 ;;
  subtract_slowly.

(* ----------------------------------------------------------------- *)
(** *** 무한 반복문 *)

Definition loop : com :=
  WHILE BTrue DO
    SKIP
  END.

(* ################################################################# *)
(** * 명령어를 실행하기 *)

(** 다음으로 Imp 명령어를 실행하는 것이 의미하는 바를 정의할 필요가
    있다. [WHILE] 반복문은 반드시 종료하지 않아도 되기 때문에 실행
    함수를 정의할 때 까다롭다... *)

(* ================================================================= *)
(** ** 함수로 명령어 실행하기 (실패한 시도) *)

(** [WHILE] 경우를 생략하고 명령어를 실행하는 함수를 정의해본다.  *)

Fixpoint ceval_fun_no_while (st : state) (c : com)
                          : state :=
  match c with
    | SKIP =>
        st
    | x ::= a1 =>
        t_update st x (aeval st a1)
    | c1 ;; c2 =>
        let st' := ceval_fun_no_while st c1 in
        ceval_fun_no_while st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_fun_no_while st c1
          else ceval_fun_no_while st c2
    | WHILE b DO c END =>
        st  (* bogus *)
  end.

(** OCaml이나 Haskell과 같은 전통적인 함수형 프로그래밍 언어에서
    다음과 같이 [WHILE]을 추가할 수도 있을 것이다.

  Fixpoint ceval_fun (st : state) (c : com) : state := match c with
    ...  | WHILE b DO c END => if (beval st b) then ceval_fun st (c;
    WHILE b DO c END) else st end.

    콕은 이런 정의를 받아들이지 않는다 ("에러: fix의 감소하는 인자를
    추측할 수 없다"). 왜냐하면 정의하고자 하는 함수가 종료하지 않을 수
    있기 때문이다. 정말로 항상 종료하는 것은 _아니다_. 예를 들어
    [ceval_fun] 함수의 전체 버전을 위의 [loop] 프로그램에 적용하면
    결코 종료하지 않을 것이다. 콕은 단지 함수형 프로그래밍 언어일 뿐만
    아니라 일관성있는 논리이기 때문에 잠재적으로 종료하지 않는 함수는
    제외할 필요가 있다. 만일 콕에서 비종료 재귀함수를 허용하면 잘못될
    수 있다는 것을 보여주는 (무효!) 프로그램이 여기 있다.

         Fixpoint loop_false (n : nat) : False := loop_false n.

    즉 [False]와 같은 명제가 증명 가능할 수 있게 될 것이다
    ([loop_false 0]는 [False]를 증명하는 것이다). 이러한 상황으로 콕의
    논리적 일관성에 재앙이 발생할 것이다.

    이렇게 [ceval_fun]의 모든 입력에 대해 종료하지 않기 때문에 콕으로
    작성할 수 없다.  작성하려면 추가적인 트릭과 회피 방법이 필요하다
    (이러한 방법이 무엇인지 궁금하면 [ImpCEvalFun] 장을 보시오).  *)

(* ================================================================= *)
(** ** 관계로 계산하기 *)

(** 여기 더 나은 방법이 있다. [ceval]을 _함수_가 아닌 _관계_로
    정의하라. 즉, 앞에서 [aevalR]에 대해 그랬듯이 [Type] 대신
    [Prop]으로 정의하라. *)

(** 이 것은 중요한 변화다. 서투른 대체 방법을 사용하지 않고 정의에서
    더 많은 유연성을 준다. 예를 들어, [any] 같은 비결정적 특징을
    언어에 추가하려면 실행 정의도 비결정적이기를 원한다. 즉, 전사
    매핑도 아니고 함수도 아니다! *)

(** [ceval] 관계를 [c / st \\ st'] 표기법을 사용할 것이다.  [c / st \\
    st']는 시작 상태 [st]에서 프로그램 [c]를 실행하고 종료 상태
    [st']를 결과로 낸다. "[c]는 [st]를 받아서 [st']으로 간다"라고 읽을
    수 있다. *)

(* ----------------------------------------------------------------- *)
(** *** 실행과정을 고려한 의미 *)

(** 계산에 관한 비정형적 정의는 다음과 같다. 가독성을 위하여 추론 규칙으로 표현하였다.

                           ----------------                            (E_Skip)
                           SKIP / st \\ st

                           aeval st a1 = n
                   --------------------------------                     (E_Ass)
                   x := a1 / st \\ (t_update st x n)

                           c1 / st \\ st'
                          c2 / st' \\ st''
                         -------------------                            (E_Seq)
                         c1;;c2 / st \\ st''

                          beval st b1 = true
                           c1 / st \\ st'
                -------------------------------------                (E_IfTrue)
                IF b1 THEN c1 ELSE c2 FI / st \\ st'

                         beval st b1 = false
                           c2 / st \\ st'
                -------------------------------------               (E_IfFalse)
                IF b1 THEN c1 ELSE c2 FI / st \\ st'

                         beval st b = false
                    ------------------------------               (E_WhileFalse)
                    WHILE b DO c END / st \\ st

                          beval st b = true
                           c / st \\ st'
                  WHILE b DO c END / st' \\ st''
                  ---------------------------------               (E_WhileTrue)
                    WHILE b DO c END / st \\ st''
*)

(** 여기 형식적인 정의가 있다. 이 것이 어떻게 추론 규칙에 상응하는지
    확실히 이해하시오.  *)

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

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st \\ st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st \\ (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  \\ st' ->
      c2 / st' \\ st'' ->
      (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st \\ st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      c / st \\ st' ->
      (WHILE b DO c END) / st' \\ st'' ->
      (WHILE b DO c END) / st \\ st''

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

(** 함수 대신 관계로 계산을 정의하면 어떤 프로그램이 어떤 결과 상태로
    계산되는 _증명_을 이제 만들 필요가 있다. 콕의 계산 방법을 그대로
    활용할 수는 없다. *)

Example ceval_example1:
    (X ::= ANum 2;;
     IFB BLe (AId X) (ANum 1)
       THEN Y ::= ANum 3
       ELSE Z ::= ANum 4
     FI)
   / empty_state
   \\ (t_update (t_update empty_state X 2) Z 4).
Proof.
  (* 중간 상태를 제공해야 한다 *)
  apply E_Seq with (t_update empty_state X 2).
  - (* 할당 명령어 *)
    apply E_Ass. reflexivity.
  - (* 조건 명령어 *)
    apply E_IfFalse.
      reflexivity.
      apply E_Ass. reflexivity.  Qed.

(** **** 연습문제: 별 두 개 (ceval_example2)  *)
Example ceval_example2:
    (X ::= ANum 0;; Y ::= ANum 1;; Z ::= ANum 2) / empty_state \\
    (t_update (t_update (t_update empty_state X 0) Y 1) Z 2).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 고급 (pup_to_n)  *)
(** [1]부터 [X]까지 숫자들을 합하는 [1 + 2 + ... + X] Imp 프로그램을
    작성하시오. [X] = [2]에 대해서 이 프로그램이 의도한 대로
    실행한다고 증명하시오 (이 증명은 생각보다 더 까다롭다). *)

Definition pup_to_n : com
  (* 이 줄을 당신의 정의로 바꾸시오 *). Admitted.

Theorem pup_to_2_ceval :
  pup_to_n / (t_update empty_state X 2) \\
    t_update (t_update (t_update (t_update (t_update (t_update empty_state
      X 2) Y 0) Y 2) X 1) Y 3) X 0.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** 실행 결정성 *)

(** 실행을 계산 기반 정의에서 관계형 정의로 바꾸는 것은 좋다. 왜냐하면
    실행이 전사 함수이어야 한다는 가공의 요구사항을 따를 필요가 없기
    때문이다. 하지만 의문이 발생한다. 실행의 두번째 정의는 정말로 부분 함수인가?
    아니면 동일한 상태 [st]에서 시작해서 명령어 [c]를 다른 방법으로 실행하여
    두 가지 다른 출력 상태들 [st']과 [st'']에 도달할 수 있을까?

    사실 이런 상황은 발생할 수 없다. [ceval]은 부분 함수_이다_. *)

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1;
           intros st2 E2; inversion E2; subst.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.
  - (* E_IfTrue, b1은 true로 계산된다 *)
      apply IHE1. assumption.
  - (* E_IfTrue,  b1은 false로 계산된다 (모순) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse, b1은 true로 계산된다 (모순) *)
    rewrite H in H5. inversion H5.
  - (* E_IfFalse, b1은 false로 계산된다 *)
      apply IHE1. assumption.
  - (* E_WhileFalse, b1은 false로 계산된다 *)
    reflexivity.
  - (* E_WhileFalse, b1은 true로 계산된다 b1 evaluates to true (모순) *)
    rewrite H in H2. inversion H2.
  - (* E_WhileTrue, b1은 false로 계산된다 (모순) *)
    rewrite H in H4. inversion H4.
  - (* E_WhileTrue, b1은 true로 계산된다 *)
      assert (st' = st'0) as EQ1.
      { (* Proof of assertion *) apply IHE1_1; assumption. }
      subst st'0.
      apply IHE1_2. assumption.  Qed.

(* ################################################################# *)
(** * Imp 프로그램에 대한 추론 *)

(** 다음 장들에서 Imp 프로그램에 대해 추론하는 체계적인 기법들을 더
    자세하게 살펴볼 것이다. 하지만 정의 자체만으로 꽤 많은 것을 할 수
    있다.  이 절에서 몇 가지 예제들을 살핀다. *)

Theorem plus2_spec : forall st n st',
  st X = n ->
  plus2 / st \\ st' ->
  st' X = n + 2.
Proof.
  intros st n st' HX Heval.

  (** [Heval]을 인버팅하여 [ceval] 계산의 한 단계를 확장한다.  이 경우
      [plus2]는 할당문이므로 [st']은 [X]의 새로운 값으로 확장한
      [st]이어야 한다. *)

  inversion Heval. subst. clear Heval. simpl.
  apply t_update_eq.  Qed.

(** **** 연습문제: 별 세 개, 추천 (XtimesYinZ_spec)  *)
(** [XtimesYinZ]의 명세를 기술하고 증명하시오. *)

(* 여기를 채우시오 *)
(** [] *)

(** **** 연습문제: 별 세 개, 추천 (loop_never_stops)  *)
Theorem loop_never_stops : forall st st',
  ~(loop / st \\ st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef
           eqn:Heqloopdef.

  (** [loopdef]가 종료함을 보이는 가정한 유도에 대한 귀납법에 따라
      진행하시오.  대부분의 경우 즉시 모순이 발생한다 (그리고
      [inversion]으로 진행한 한 단계에서 해결될 수 있을 것이다.) *)

  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개 (no_whilesR)  *)
(** 다음 함수를 고려하자 *)

Fixpoint no_whiles (c : com) : bool :=
  match c with
  | SKIP =>
      true
  | _ ::= _ =>
      true
  | c1 ;; c2 =>
      andb (no_whiles c1) (no_whiles c2)
  | IFB _ THEN ct ELSE cf FI =>
      andb (no_whiles ct) (no_whiles cf)
  | WHILE _ DO _ END  =>
      false
  end.

(** 이 명제는 while 반복문이 없는 프로그램의 경우에 대해서만 [true]를
    낸다.  [Inductive]를 사용하여 [no_whilesR] 성질을
    작성하시오. [no_whilesR c]는 [c]에 while 반복문이 없는 프로그램일
    때 증명가능하다는 성질이다. 그런 다음 [no_whiles]와 동치임을
    증명하시오. *)

Inductive no_whilesR: com -> Prop :=
 (* 여기를 채우시오 *)
.

Theorem no_whiles_eqv:
   forall c, no_whiles c = true <-> no_whilesR c.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 네 개 (no_whiles_terminating)  *)
(** while 반복문을 포함하지 않는 Imp 프로그램은 항상 종료한다.  이에
    관한 [no_whiles_terminating] 정리를 기술하고 증명하시오. *)
(** [no_whiles]이나 [no_whilesR] 중 선호하는 것을 사용하시오. *)

(* 여기를 채우시오 *)
(** [] *)

(* ################################################################# *)
(** * 추가 연습문제 *)

(** **** 연습문제: 별 세 개 (stack_compiler)  *)
(** HP 계산기, Forth와 Postscript 같은 프로그래밍 언어, Java
    가상기계와 같은 추상 기계는 모두 스택을 사용하여 산술식을
    계산한다. 예를 들어, 식

      (2*3)+(3*(4-2))

   은 다음과 같은 순서로 입력하고

      2 3 * 3 4 2 - * +

   그리고 이렇게 계산한다 (오른편에 실행 과정의 프로그램과 왼편에 스택
   내용을 보여준다).

      [ ] | 2 3 * 3 4 2 - * + [2] | 3 * 3 4 2 - * + [3, 2] | * 3 4 2 -
      * + [6] | 3 4 2 - * + [3, 6] | 4 2 - * + [4, 3, 6] | 2 - * + [2,
      4, 3, 6] | - * + [2, 3, 6] | * + [6, 6] | + [12] |

  이 연습문제에서 할 일은 [aexp]를 스택 기계 명령어로 번역하는 작은
  컴파일러를 작성하는 것이다.

  스택 언어에 대한 명령어 집합은 다음 명령어들로 구성될 것이다. [SPush
  n]: 숫자 [n]을 스택에 올려 넣는다. [SLoad x]: 변수 [x]의 값을
  메모리에서 불러와서 스택에 올려 넣는다. [SPlus]: 스택 맨 위 두
  숫자들을 꺼내서 더하고 그 결과를 다시 스택에 올려 넣는다. [SMinus]:
  비슷한 방식으로 뺄셈을 수행한다. [SMult]: 비슷한 방식으로 곱셈을
  한다. *)

Inductive sinstr : Type :=
| SPush : nat -> sinstr
| SLoad : id -> sinstr
| SPlus : sinstr
| SMinus : sinstr
| SMult : sinstr.

(** 스택 언어에서 프로그램을 계산하는 함수를 작성하시오. 입력으로
    상태, 숫자 리스트로 표현한 스택, 명령어 리스트로 표현한 프로그램을
    받아 프로그램 실행 후의 스택을 리턴해야 한다. 당신의 함수를 아래에
    나열된 예제들을 가지고 테스트하시오.

    [SPlus], [SMinus], [SMult] 명령어를 실행할 때 스택에 두 개 보다
    적은 원소를 포함한다면 어떻게 해야할지 명령어 명세에 규정되어 있지
    않음을 주목하라. 어떤 면에서는 그러한 상황에 무엇을 할 지 중요하지
    않다. 왜냐하면 우리 컴파일러는 그러한 잘못 구성된 프로그램을 결코
    만들지 않을 것이기 때문이다. *)

Fixpoint s_execute (st : state) (stack : list nat)
                   (prog : list sinstr)
                 : list nat
  (* 이 줄을 당신의 정의로 바꾸시오 *). Admitted.

Example s_execute1 :
     s_execute empty_state []
       [SPush 5; SPush 3; SPush 1; SMinus]
   = [2; 5].
(* 여기를 채우시오 *) Admitted.

Example s_execute2 :
     s_execute (t_update empty_state X 3) [3;4]
       [SPush 4; SLoad X; SMult; SPlus]
   = [15; 4].
(* 여기를 채우시오 *) Admitted.

(** 다음으로 [aexp]를 스택 기계 프로그램으로 컴파일하는 함수를
    작성하시오.  프로그램을 실행하는 효과는 그 식의 값을 스택에 올려
    놓는 것과 동일해야 한다.  *)

Fixpoint s_compile (e : aexp) : list sinstr
  (* 이 줄을 당신의 정의로 바꾸시오 *). Admitted.

(** [s_compile]을 정의한 다음 동작 여부를 테스트하기 위해 다음을
    증명하시오. *)

Example s_compile1 :
    s_compile (AMinus (AId X) (AMult (ANum 2) (AId Y)))
  = [SLoad X; SPush 2; SLoad Y; SMult; SMinus].
(* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 네 개, 고급 (stack_compiler_correct)  *)
(** 이전 연습문제에서 구현한 컴파일러의 정확성을 이제 증명할 것이다.
    [SPlus], [SMinus], [SMult] 명령어가 두 개 보다 적은 원소들을
    포함하는 스택을 만나면 무엇을 할 지 명세에서 규정하고 있지 않음을
    기억하시오 (정확성 증명을 더 쉽게 하려면 돌아가서 구현 방법을
    변경하는 것이 필요할 수도 있다!).

    다음 정리를 증명하시오. 더 일반적인 보조 정리를 기술하여 사용할 수
    있는 귀납적 가정을 얻을 필요가 있을 것이다. 주 정리는 이 보조
    정리의 간단한 따름 정리가 될 것이다. *)

Theorem s_compile_correct : forall (st : state) (e : aexp),
  s_execute st [] (s_compile e) = [ aeval st e ].
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 선택 사항 (short_circuit)  *)
(** 대부분의 현대 프로그래밍 언어는 부울 [and]에 대한 "단락" 계산
    규칙을 사용한다.  [BAnd b1 b2]를 계산하려면 먼저 [b1]을
    계산한다. 그 결과가 [false]이면 [b2]를 계산하지 않고 전체 [BAnd]
    식이 즉시 [false]가 된다. 그렇지 않다면 [b1]를 계산해서 [BAnd]
    식의 결과를 결정한다.

    설명한 방식으로 [BAnd]의 단락 계산을 수행하도록 [beval]의 대체
    버전을 작성하고, [beval]과 동치임을 증명하시오. *)

(* 여기를 채우시오 *)
(** [] *)

Module BreakImp.
(** **** 연습문제: 별 네 개, 고급 (break_imp)  *)

(** C와 Java 같은 명령형 언어는 반복문 실행을 중지하는 [break]나
    비슷한 문장을 포함한다. 이 연습문제에서 Imp에 [break]를 추가하는
    법을 고려하자. 우선 명령어 언어를 추가 명령어로 확장할 필요가
    있다. *)

Inductive com : Type :=
  | CSkip : com
  | CBreak : com               (* <-- new *)
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "'BREAK'" :=
  CBreak.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

(** 그 다음 [BREAK]의 동작을 정의할 필요가 있다. 비형식적으로 일련의
    명령어들 중 하나로 [BREAK]를 실행할 때 그 명령어들 실행을 중단하고
    가장 안쪽 내포된 반복문이 끝나야 한다고 알린다. (만일 감싸는
    반복문이 없으면 전체 프로그램이 종료한다.) 마지막 상태는 [BREAK]
    문장이 실행되었을 때 상태와 동일해야 한다.

    한 가지 중요한 점은 주어진 [BREAK]를 감싸는 여러 반복문들이 있을
    때 어떻게 동작할 지 정의하는 것이다. 그러한 경우에 [BREAK]는 _가장
    안쪽_ 반복문만 종료시킨다. 이렇게 다음을 실행한 다음...

       X ::= 0;; Y ::= 1;; WHILE 0 <> Y DO WHILE TRUE DO BREAK END;; X
       ::= 1;; Y ::= Y - 1 END

    ... [X]의 값은 [1]이 되어야 하고 [0]이 아니다.

    이러한 동작을 표현하는 한 가지 방법은, 계산 관계에 새로운
    패러미터를 추가해서 다음 실행할 명령어가 [BREAK] 문장인지 규정하는
    것이다. *)

Inductive result : Type :=
  | SContinue : result
  | SBreak : result.

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

(** 직관적으로 [c / st \\ s / st']는 만일 [c]를 상태 [st]에서 시작하면
    [st']에서 종료하고 맨 안쪽에 감싸는 반복문 (또는 전체 프로그램)은
    즉시 빠져나가야 한다 ([s = SBreak]) 또는 이 실행은 정상적으로
    이어가야 한다 ([S = SContinue]).

    [c / st \\ s / st'] 관계의 정의는 정규 계산 관계 [c / st \\ st']를
    정의한 것과 매우 유사하다. 단지 종료할지 알리는 신호를 적절히
    처리할 필요만 있을 뿐이다.

    - [SKIP] 명령어의 경우 상태는 바뀌지 않고 감싸고 있는 어떤
      반복문도 정상적으로 실행을 계속한다.

    - [BREAK] 명령어의 경우 상태는 바뀌지 않지만 [SBreak] 신호를
      보낸다.

    - 할당문의 경우 현재 상태의 변수 값을 문장에 따라 바꾸고
      정상적으로 실행을 계속한다.

    - [IFB b THEN c1 ELSE c2 FI] 형태의 명령어의 경우 상태는 Imp의
      원래 의미에 따라 변경되도록 하되 어느 분기가 선택되었는지
      무관하게 그 분기를 실행하면서 발생한 신호를 전파한다.

    - [c1 ;; c2] 형태의 명령어의 경우 [c1]을 먼저 실행한다. 만일
      [SBreak] 신호가 발생하면 [c2]를 실행하지 않고 [SBreak] 신호를
      감싸는 문맥에 전파한다. 결과 상태는 [c1]을 실행하면서 얻는
      상태와 동일하다. 만일 [c1] 실행에서 [SBreak] 신호가 발생하지
      않으면 [c1]을 실행해서 얻은 상태에서 [c2]를 실행하고 거기에서
      발생한 신호가 있다면 전파한다.

    - 마지막으로 [WHILE b DO c END] 형태의 반복문의 의미는 이전과 거의
      동일하다.  유일하게 다른 점은 [b]가 true일 때 [c]를 계산하고
      [c]에서 신호를 발생했는지 검사하는 것이다. 신호가
      [SContinue]이면 원래 의미대로 실행을 진행하간다.  그렇지 않으면
      반복문 실행을 멈추고 결과 상태를 현재 반복의 실행에서 나온
      상태와 동일하다. 어느 경우든 [BREAK]는 가장 안쪽의 반복문만을
      종료시키기 때문에 [WHILE]은 [SContinue] 신호를 낸다.  *)

(** 위에서 기술한 바에 따라 [ceval] 관계를 정의하시오. *)

Inductive ceval : com -> state -> result -> state -> Prop :=
  | E_Skip : forall st,
      CSkip / st \\ SContinue / st
  (* 여기를 채우시오 *)

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

(** 이제 [ceval] 정의 다음 성질들을 증명하시오.  *)

Theorem break_ignore : forall c st st' s,
     (BREAK;; c) / st \\ s / st' ->
     st = st'.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem while_continue : forall b c st st' s,
  (WHILE b DO c END) / st \\ s / st' ->
  s = SContinue.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem while_stops_on_break : forall b c st st',
  beval st b = true ->
  c / st \\ SBreak / st' ->
  (WHILE b DO c END) / st \\ SContinue / st'.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 고급, 선택 사항 (while_break_true)  *)
Theorem while_break_true : forall b c st st',
  (WHILE b DO c END) / st \\ SContinue / st' ->
  beval st' b = true ->
  exists st'', c / st'' \\ SBreak / st'.
Proof.
(* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 네 개, 고급, 선택 사항 (ceval_deterministic)  *)
Theorem ceval_deterministic: forall (c:com) st st1 st2 s1 s2,
     c / st \\ s1 / st1  ->
     c / st \\ s2 / st2 ->
     st1 = st2 /\ s1 = s2.
Proof.
  (* 여기를 채우시오 *) Admitted.

(** [] *)
End BreakImp.

(** **** 연습문제: 별 네 개, 선택 사항 (add_for_loop)  *)
(** C 스타일 [for] 반복문을 명령어 언어에 추가하고, [for] 반복문의
    의미를 정의하도록 [ceval] 정의를 수정하고, [for] 반복문에 필요한
    경우들을 추가해서 이 파일에 있는 모든 증명을 여전히 콕이
    받아드리도록 작성하시오.

    [for] 반복문은 (a) 처음 실행하는 문장, (b) 반복문의 각 반복마다 이
    반복문을 계속 수행할지 결정하기 위해서 실행하는 검사, (c) 반복문의
    각 반복의 끝에 실행할 문장, (d) 반복문의 몸체를 구성하는 문장으로
    구성되어 있다. ([for] 반복문의 실제 표기법을 구성하는 것에 대해서
    고민할 필요는 없다. 원한다면 이 표기법도 자유롭게 정의해보라.) *)

(* 여기를 채우시오 *)
(** [] *)

(** $Date: 2017-08-25 14:01:35 -0400 (Fri, 25 Aug 2017) $ *)


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Let's define partial functions as lists.
  We have just too many unique domain constraints.
*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Definition pfun (A : Type) (B : Type) := list (A * B).

(* TODO I could make this a relation and then check at each add that I am
  not overwriting the domain. *)
Function plusl (A : Type) (B : Type) (x : A*B) (p : pfun A B) : pfun A B :=
  x :: p.
Function plusr (A : Type) (B : Type) (p : pfun A B) (x : A * B) : pfun A B :=
  p ++ [x].
Function union (A : Type) (B : Type)
         (p1 : pfun A B) (p2 : pfun A B) : pfun A B :=
  p1 ++ p2.

Notation "x |+ y" := (plusl x y)
                       (at level 60, right associativity).
Notation "[ x |; .. |; y ]" := (cons x .. (cons y []) ..).
Notation "|[ ]" := [].
Notation "x |++ y" := (union x y)
                       (at level 60, right associativity).
(* TODO Map or ? *)

Function Dom (A : Type) (B : Type) (p : pfun A B) : list A :=
  match p with
   | (a,b) :: p' => a :: Dom A B p'
   | |[] => |[]
  end.

Function notindom (A : Type) (B : Type) (a : A) (p : pfun A B) : Prop :=
  match a, p with
   | b, (b',_) :: p' => b = b'
   | _ , |[] => True
  end.

Inductive WFpfun : Type -> Type -> pfun Type Type  -> Prop :=
  | WFpfun_nil   : WFpfun _ _ |[]
  | WFpfun_plus : forall  (A : Type) (B : Type) (a : A * B) (p : pfun A B),
                    WFpfun (a |+ p).

(* How do I put an invarient in here? I don't think I can. *)


Require Import mathcomp.ssreflect.all_ssreflect.
From Equations Require Import Equations.
Require Import Arith.Wf_nat.
Set Bullet Behavior "Strict Subproofs".

(* Transforms a coq_nat less-than into ssreflect's less-than *)
Ltac leP_of_coq_nat :=
  match goal with
  | |- (_ < _)%coq_nat => apply/leP
  | _                  => idtac
  end.

Show Obligation Tactic.
Obligation Tactic :=
  Tactics.program_simplify; Tactics.equations_simpl;
    try Tactics.program_solve_wf;
    leP_of_coq_nat; try done.

(* ------------------------------------------------------ *)

Equations f1 (x : nat) : nat by wf x lt :=
  f1 0       := 0 ;
  f1 (S xm1) := S (f1 xm1).

Lemma def_f1 x : f1 x = match x with | 0 => 0 | S xm1 => S (f1 xm1) end.
Proof. by apply: f1_unfold_eq. Qed.

Lemma f1_id x : f1 x = x.
Proof.
  elim: x.
  - done.
  - move=> x' IHx'.
    by rewrite def_f1 IHx'.
Qed.

(* ------------------------------------------------------ *)

(* Occurrence Typing / Logical Types for Untyped Languages / Flow Stuff *)
Definition if_eq A c : (c = true -> A) -> (c = false -> A) -> A :=
  match c with
  | true  => fun t _ => t erefl
  | false => fun _ e => e erefl
  end.
Arguments if_eq {A} c t e.

Equations f2 (x : nat) : nat by wf x lt :=
  f2 x := if_eq (x == 0)
                (fun xeq0 => 0)
                (fun xne0 => S (f2 (x - 1))).
Next Obligation.
  move: f2 => _.
  case: x xne0.
  - done.
  - move=> x' _.
    by rewrite subn1.
Qed.

Lemma def_f2 x : f2 x = if_eq (x == 0) (fun xeq0 => 0) (fun xne0 => S (f2 (x - 1))).
Proof. by apply: f2_unfold_eq. Qed.

Lemma f2_id x : f2 x = x.
Proof.
  elim: x.
  - done.
  - move=> x IHx.
    by rewrite def_f2 subn1 IHx.
Qed.

(* ------------------------------------------------------ *)

Definition collatz_next (x : nat) : nat :=
  if Nat.even x
  then x./2
  else (3 * x) + 1.

(* repeat until local minimum *)
Equations f3 (x : nat) : nat by wf x lt :=
  f3 x
  :=
  let y := collatz_next x in
  if_eq (y < x)
        (fun yltx => f3 y)
        (fun _    => x).

Lemma not_lt_3xp1x x : 3 * x + 1 < x = false.
Proof.
  apply/eqP.
  by rewrite addn1 mulSn -2!addnS addKn.
Qed.

Lemma f3_not_even_id x : (Nat.even x = false) -> (f3 x = x).
Proof.
  move=> oddx.
  rewrite f3_equation_1.
  unfold collatz_next.
  by rewrite oddx not_lt_3xp1x.
Qed.

(* ------------------------------------------------------ *)

(* repeat until local minimum, generic *)
Equations repeat_while_smaller A (size : A -> nat) (f : A -> A) (a : A) : A by wf (size a) lt :=
  repeat_while_smaller A size f a
  :=
  let b := f a in
  if_eq (size b < size a)
        (fun blta => repeat_while_smaller A size f b)
        (fun nlt  => a).

Lemma repeat_while_smaller_ind :
  forall (A : Set) (size : A -> nat) (P : A -> Prop),
    (forall (a : A) (IHa : forall (b : A), (size b < size a) -> P b), P a)
    ->
    (forall (a : A), P a).
Proof.
  move=> A size P H a.
  apply:
    (lt_wf_ind
       (size a)
       (fun (sa : nat) => forall (a : A), (sa = size a) -> (P a))).
  - move=> sa IHa a' Heqsa.
    apply: (H a').
    move=> b blta.
    move/ltP in blta.
    rewrite -Heqsa in blta.
    by apply: (IHa (size b) blta b erefl).
  - done.
Qed.

Lemma repeat_while_smaller_preserves_reflexive_transitive :
  forall
    (A : Set)
    (R : A -> A -> Prop)
    (Rrefl : forall a, R a a)
    (Rtrans : forall a b c, R a b -> R b c -> R a c)
    (size : A -> nat)
    (step1 : A -> A)
    (Rstep1 : forall a, R a (step1 a)),
    (* --------------------- *)
    forall a, R a (repeat_while_smaller A size step1 a).
Proof.
  move=> A R Rrefl Rtrans size step1 Rstep1 a.
  induction a using (repeat_while_smaller_ind A size).
  - rewrite repeat_while_smaller_equation_1.
    remember (step1 a) as b => //=.
    case blta: (size b < size a) => //=.
    apply: Rtrans.
    + by apply: Rstep1.
    + rewrite -Heqb.
      by apply: IHa.
Qed.


(* In LiftedTensor.v and LiftedTensor.v, we have shown that given a category C equipped with a binary operation T and an object I (called the tensor and unit resp.),
then, this structures 'transport' to a weakly equivalent univalent category D, by a weak equivalence H:C->D, making this univalent category D with a tensor and unit,
the free univalent category equipped with a tensor and a unit.
In this file, we show that if we equip (C,T) with an associator, then
1: the associator also transports to D.
2: H preserves the associator as a monoidal functor preserves the associator.
3: H makes D the free univalent category equipped with tensor, unit and the associator.
More details about the universality and the Rezk-completion can be found in LiftedMonoidal.v
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.catiso.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.PrecompEquivalence.

Require Import UniMath.CategoryTheory.PrecategoryBinProduct.

Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.TotalCategoryFacts.

Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedTensor.
Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedTensorUnit.

Local Open Scope mor_disp.
Local Open Scope cat.

Section RezkAssociator.

  Context {C D : category} {H : functor C D}
          (Duniv : is_univalent D)
          (H_eso : essentially_surjective H)
          (H_ff : fully_faithful H).

  Context (TC : functor (C ⊠ C) C)
          (α : associator TC).

  Definition DDDuniv : is_univalent ((D ⊠ D) ⊠ D).
  Proof.
    apply is_univalent_category_binproduct.
    2: exact Duniv.
    apply is_univalent_category_binproduct.
    exact Duniv.
    exact Duniv.
  Qed.

  Let TD := TransportedTensor Duniv H_eso H_ff TC.

  Local Notation HH := (pair_functor H H).
  Let HH_eso := pair_functor_eso H H H_eso H_eso.
  Let HH_ff := pair_functor_ff H H H_ff H_ff.

  Local Notation HHH := (pair_functor HH H).
  Let HHH_eso := pair_functor_eso HH H HH_eso H_eso.
  Let HHH_ff := pair_functor_ff HH H HH_ff H_ff.

  Local Notation HHH' := (pair_functor H HH).
  Let HHH'_eso := pair_functor_eso _ _ H_eso HH_eso.
  Let HHH'_ff := pair_functor_ff _ _ H_ff HH_ff.

  Lemma TransportedAssocLeft
    :  nat_z_iso (HHH ∙ assoc_left TD) (assoc_left TC ∙ H).
  Proof.
    use nat_z_iso_comp.
    3: apply nat_z_iso_functor_comp_assoc.
    use nat_z_iso_comp.
    2: apply nat_z_iso_functor_comp_assoc.
    use nat_z_iso_comp.
    3: {
      apply pre_whisker_nat_z_iso.
      apply ((TransportedTensorComm Duniv H_eso H_ff _)).
    }
    use nat_z_iso_comp.
    3: apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)).
    use (post_whisker_nat_z_iso _ TD).

    use nat_z_iso_comp.
    3: apply PrecompEquivalence.nat_z_iso_pair.
    use nat_z_iso_comp.
    2: apply pair_functor_composite.

    use pair_nat_z_iso.
    - apply TransportedTensorComm.
    - apply functor_commutes_with_id.
  Defined.

  Lemma TransportedAssocLeftOnOb (x y z : C)
    : TransportedAssocLeft ((x,y),z)
      = # TD (TransportedTensorComm Duniv H_eso H_ff TC (x,y) #, identity (H z))
          · (TransportedTensorComm Duniv H_eso H_ff TC (TC (x,y) , z)).
  Proof.
    cbn.
    rewrite ! id_left.
    rewrite ! id_right.
    apply idpath.
  Qed.

  Lemma unassoc_commutes
    : nat_z_iso (HHH ∙ (precategory_binproduct_unassoc D D D))
                ((precategory_binproduct_unassoc C C C) ∙ (pair_functor H HH)).
  Proof.
    use make_nat_z_iso.
    - use make_nat_trans.
      + intro ; use catbinprodmor ; apply identity.
      + intro ; intros.
        use total2_paths_f.
        * exact (id_right _ @ ! id_left _).
        * abstract (rewrite transportf_const ; exact (id_right _ @ ! id_left _)).
    - intro.
      use tpair.
      * use catbinprodmor ; apply identity.
      * abstract (split ; (use total2_paths_f ; [ apply id_right | rewrite transportf_const ; apply id_right ])).
  Defined.

  Lemma TransportedAssocRight
    : nat_z_iso (HHH ∙ assoc_right TD) (assoc_right TC ∙ H).
  Proof.
    (* This commuting diagram can be split in 3 commuting diagrams stacked together *)
    (* Step 1: The top commuting diagram is unassoc_commutes *)
    use nat_z_iso_comp.
    2: apply nat_z_iso_functor_comp_assoc.
    use nat_z_iso_comp.
    2: {
      use post_whisker_nat_z_iso.
      2: exact unassoc_commutes.
    }
    use nat_z_iso_comp.
    2: apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)).
    use nat_z_iso_comp.
    3: apply nat_z_iso_functor_comp_assoc.
    apply pre_whisker_nat_z_iso.

    (* Step 2: The lowest commuting diagram is the tensor preserving commuting one *)
    use nat_z_iso_comp.
    3: apply nat_z_iso_functor_comp_assoc.
    use nat_z_iso_comp.
    3: {
      apply pre_whisker_nat_z_iso.
      apply TransportedTensorComm.
    }

    use nat_z_iso_comp.
    3: apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)).
    use nat_z_iso_comp.
    2: apply nat_z_iso_functor_comp_assoc.
    apply post_whisker_nat_z_iso.

    (* Step 3: The middle commuting square is the tensor preserving commuting one
               but tensored with the identity functor on the left *)

    use product_of_commuting_squares.
    { apply (make_nat_z_iso _ _ _ (is_nat_z_iso_nat_trans_id H)). }
    apply TransportedTensorComm.
  Defined.

  Lemma TransportedAssocRightOnOb (x y z : C)
    : TransportedAssocRight ((x,y),z)
      =  # TD (# H (id x) #, TransportedTensorComm Duniv H_eso H_ff TC (y, z))
           · TransportedTensorComm Duniv H_eso H_ff TC (x, TC (y,z)).
  Proof.
    cbn.
    rewrite ! id_left.
    rewrite ! id_right.
    rewrite ! functor_id.
    rewrite ! assoc.
    apply maponpaths_2.
    fold (TransportedTensor Duniv H_eso H_ff).
    etrans. {
      apply (! functor_comp TD _ _).
    }
    apply maponpaths.
    rewrite <- binprod_comp.
    rewrite id_right.
    apply maponpaths.
    etrans. {
      apply maponpaths_2.
      apply (functor_id TD).
    }
    apply id_left.
  Qed.

  Lemma TransportedAssocRightInvOnOb (x y z : C)
    : nat_z_iso_inv TransportedAssocRight ((x,y),z)
      = nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC)
          (x, TC (y,z))
          · # TD (# H (id x) #, (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC) (y, z))).
  Proof.
    use (z_iso_inv_to_left _ _ _
                           (_,,pr2 (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC)) (x, TC (y,z)))).
    use (z_iso_inv_to_right _ _ _ _
                            (_,, pr2 (nat_z_iso_inv TransportedAssocRight) ((x, y), z))).
    set (t := TransportedAssocRightOnOb x y z).
    etrans.
    2: {
      apply maponpaths.
      apply (! t).
    }
    etrans.
    2: {
      rewrite assoc.
      apply maponpaths_2.
      apply (functor_comp TD).
    }
    etrans.
    2: {
      apply maponpaths_2.
      apply maponpaths.
      apply binprod_comp.
    }
    etrans.
    2: {
      apply maponpaths_2.
      apply maponpaths.
      rewrite (functor_id H).
      rewrite id_right.
      apply maponpaths.
      apply (! pr22 ((pr2 (TransportedTensorComm Duniv H_eso H_ff TC)) (y, z))).
    }
    etrans.
    2: {
      apply maponpaths_2.
      rewrite binprod_id.
      apply (! functor_id TD _).
    }
    apply (! id_left _).
  Qed.

  Definition TransportedAssociator
    : associator TD.
  Proof.
    use (lift_nat_z_iso_along (_,,Duniv) HHH HHH_eso HHH_ff).
    use nat_z_iso_comp.
    3: apply (nat_z_iso_inv (TransportedAssocRight)).
    use nat_z_iso_comp.
    2: exact TransportedAssocLeft.
    exact (post_whisker_nat_z_iso α H).
  Defined.

  Let αD := TransportedAssociator.

  Definition TransportedAssociatorEq
    : pre_whisker HHH TransportedAssociator
      = nat_z_iso_comp
          (nat_z_iso_comp TransportedAssocLeft (post_whisker_nat_z_iso α H))
          (nat_z_iso_inv (TransportedAssocRight)).
  Proof.
    set (t := lift_nat_trans_along_comm (_,,Duniv) _ HHH_eso HHH_ff
          (nat_z_iso_comp TransportedAssocLeft
                          (nat_z_iso_comp
                             (post_whisker_nat_z_iso α H)
                             (nat_z_iso_inv TransportedAssocRight)
                          )
        )).
    refine (_ @ t @ _).
    clear t.
    - apply maponpaths.
      apply (maponpaths (lift_nat_trans_along (D,, Duniv) HHH HHH_eso HHH_ff)).
      apply nat_trans_comp_assoc'.
      apply homset_property.
    - exact (nat_trans_comp_assoc (homset_property _)
                                     _ _ _ _
              (pr1 TransportedAssocLeft)
              (post_whisker_nat_z_iso α H)
              (nat_z_iso_inv TransportedAssocRight)).
  Qed.

  Definition TransportedAssociatorOnOb
    : ∏ x : (C ⊠ C) ⊠ C,
        αD (HHH x) = TransportedAssocLeft x · #H (α x) · nat_z_iso_inv TransportedAssocRight x.
  Proof.
    exact (λ x, toforallpaths _ _ _ (base_paths _ _ TransportedAssociatorEq) x).
  Qed.

  Definition assoc_left_tensor_l
    : ∏ x1 x2 x3 x4 : C,
        D⟦assoc_left TD ((TD (H x1, H x2), H x3), H x4)
           , H (assoc_left TC ((TC (x1, x2), x3), x4))⟧.
  Proof.
    do 4 intro.
    use (_ · _).
    3: apply TransportedAssocLeft.
    use (# TD).
    use catbinprodmor.
    2: apply identity.
    use (# TD).
    use catbinprodmor.
    1: exact ((TransportedTensorComm Duniv H_eso H_ff TC) (x1,x2)).
    apply identity.
  Defined.

  Definition assoc_left_tensor_m
    : ∏ x1 x2 x3 x4 : C,
        D ⟦assoc_left TD ((H x1, TD (H x2, H x3)), H x4)
            , H (assoc_left TC ((x1, TC (x2, x3)), x4))⟧.
  Proof.
    do 4 intro.
    use (_ · _).
    3: apply TransportedAssocLeft.
    use (# TD).
    use catbinprodmor.
    2: apply identity.
    apply (#TD).
    use catbinprodmor.
    1: apply identity.
    apply ((TransportedTensorComm Duniv H_eso H_ff TC) (x2,x3)).
  Defined.

  Definition assoc_left_tensor_r
    : ∏ x1 x2 x3 x4 : C,
        D ⟦assoc_left TD ((H x1, H x2), TD (H x3, H x4))
            , H (assoc_left TC ((x1, x2), TC (x3, x4))) ⟧.
  Proof.
    do 4 intro.
    use (_ · _).
    3: apply TransportedAssocLeft.
    use (# TD).
    use catbinprodmor.
    - apply identity.
    - exact ((TransportedTensorComm Duniv H_eso H_ff TC) (x3,x4)).
  Defined.

  Definition assoc_right_tensor_l
    : ∏ x1 x2 x3 x4 : C,
        D⟦ H (assoc_right TC ((TC (x1, x2), x3), x4))
           , assoc_right TD ((TD (H x1, H x2), H x3), H x4)⟧.
  Proof.
    do 4 intro.
    use (_ · _).
    2: apply TransportedAssocRight.
    use (# TD).
    use catbinprodmor.
    2: apply identity.
    exact (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC) (x1,x2)).
  Defined.

  Definition assoc_right_tensor_m
    : ∏ x1 x2 x3 x4 : C,
        D⟦H (assoc_right TC ((x1, TC (x2, x3)), x4))
           , assoc_right TD ((H x1, TD (H x2, H x3)), H x4)⟧.
  Proof.
    do 4 intro.
    use (_ · _).
    3: {
      use (# (assoc_right TD)).
      2: {
        use catbinprodmor.
        4: apply identity.
        2: {
          use catbinprodmor.
          3: apply identity.
          2: apply (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC) (x2,x3)).
        }
      }
    }
    exact (nat_z_iso_inv TransportedAssocRight ((x1,TC (x2,x3)),x4)).
  Defined.

  Definition assoc_right_tensor_r
    : ∏ x1 x2 x3 x4 : C,
        D⟦H (assoc_right TC ((x1, x2), TC (x3, x4)))
           , assoc_right TD ((H x1, H x2), TD (H x3, H x4)) ⟧.
  Proof.
    do 4 intro.
    use (_ · _).
    2: apply (nat_z_iso_inv TransportedAssocRight).
    use (# TD).
    use catbinprodmor.
    - apply identity.
    - use (# TD).
      use catbinprodmor.
      + apply identity.
      + apply TransportedTensorComm.
  Defined.

  Lemma TransportedAssociator_tensor_l_on_ob
    : ∏ x1 x2 x3 x4 : C,
        αD ((TD (H x1, H x2), H x3), H x4)
        = assoc_left_tensor_l x1 x2 x3 x4 · #H (α ((TC (x1,x2) , x3),x4)) · assoc_right_tensor_l x1 x2 x3 x4.
  Proof.
    do 4 intro.
    unfold assoc_left_tensor_l.
    unfold assoc_right_tensor_l.

    etrans.
    2: {
      rewrite assoc.
      apply maponpaths_2.
      do 2 rewrite assoc'.
      apply maponpaths.
      rewrite assoc.
      exact (TransportedAssociatorOnOb ((TC (x1,x2),x3),x4)).
    }

    etrans.
    2: {
      apply maponpaths_2.
      exact (! pr21 αD _ _   ((TransportedTensorComm Duniv H_eso H_ff TC (x1, x2)
                                                     #, id H (pr21 ((TC (x1, x2), x3), x4))) #, id functor_identity D (pr2 (HHH ((TC (x1, x2), x3), x4))))).
    }

    etrans.
    2: {
      rewrite assoc'.
      apply maponpaths.
      etrans. 2: apply (functor_comp TD).
      apply maponpaths.
      etrans. 2: apply binprod_comp.
      etrans.
      2: {
        apply maponpaths.
        etrans.
        2: apply maponpaths_2, maponpaths, (! binprod_id _ _).
        rewrite functor_id.
        apply (! id_left _).
      }

      apply maponpaths_2.
      exact (! pr12 (pr2 (TransportedTensorComm Duniv H_eso H_ff TC) (x1,x2))).
    }
    etrans.
    2: {
      apply maponpaths.
      rewrite binprod_id.
      apply (! functor_id TD _).
    }
    apply (! id_right _).
  Qed.

  Lemma TransportedAssociator_tensor_m_on_ob
    : ∏ x1 x2 x3 x4 : C,
        αD ((H x1, TD (H x2, H x3)), H x4)
        = assoc_left_tensor_m x1 x2 x3 x4 · #H (α ((x1, TC (x2,x3)),x4)) · assoc_right_tensor_m x1 x2 x3 x4.
  Proof.
    do 4 intro.
    unfold assoc_left_tensor_m.
    unfold assoc_right_tensor_m.

    etrans.
    2: {
      rewrite assoc.
      apply maponpaths_2.
      do 2 rewrite assoc'.
      apply maponpaths.
      rewrite assoc.
      exact (TransportedAssociatorOnOb ((x1, TC (x2,x3)),x4)).
    }

    etrans.
    2: {
      apply maponpaths_2.

      exact (! pr21 αD _ _  ((id H (pr11 ((x1, TC (x2, x3)), x4)) #, TransportedTensorComm Duniv H_eso H_ff TC (x2, x3))
    #, id functor_identity D (pr2 (HHH ((x1, TC (x2, x3)), x4))))).
    }

    etrans.
    2: {
      rewrite assoc'.
      apply maponpaths.
      etrans. 2: apply (functor_comp TD).
      etrans. 2: apply maponpaths, binprod_comp.

      (* simpl. *)
      rewrite id_left.
      do 2 apply maponpaths.
      etrans. 2: apply (functor_comp TD).
      apply maponpaths.
      etrans. 2: apply binprod_comp.
      apply maponpaths_2.
      exact (! pr12 (pr2 (TransportedTensorComm Duniv H_eso H_ff TC) (x2,x3))).
    }
    etrans.
    2: {
      apply maponpaths.
      rewrite id_right.
      rewrite (functor_id TD).
      simpl.
      rewrite binprod_id.
      apply (! functor_id TD _).
    }
    apply (! id_right _).
  Qed.

  Lemma TransportedAssociator_tensor_r_on_ob
    : ∏ x1 x2 x3 x4 : C,
        αD ((H x1, H x2), TD (H x3, H x4))
        = assoc_left_tensor_r x1 x2 x3 x4 · #H (α ((x1,x2) , TC (x3,x4))) · assoc_right_tensor_r x1 x2 x3 x4.
  Proof.
    do 4 intro.
    unfold assoc_left_tensor_r.
    unfold assoc_right_tensor_r.

    etrans.
    2: {
      rewrite assoc.
      apply maponpaths_2.
      do 2 rewrite assoc'.
      apply maponpaths.
      rewrite assoc.
      exact (TransportedAssociatorOnOb (((x1,x2), TC (x3,x4)))).
    }

    etrans.
    2: {
      apply maponpaths_2.
      rewrite <- (functor_id TD).
      exact (! pr21 αD _ _  (id  (pr1 (HHH ((x1, x2), TC (x3, x4)))) #, TransportedTensorComm Duniv H_eso H_ff TC (x3, x4))).
    }

    etrans.
    2: {
      rewrite assoc'.
      apply maponpaths.
      etrans. 2: apply (functor_comp TD).
      etrans. 2: apply maponpaths, binprod_comp.

      (* simpl. *)
      rewrite id_left.
      do 2 apply maponpaths.
      etrans. 2: apply (functor_comp TD).
      apply maponpaths.
      etrans. 2: apply binprod_comp.
      apply maponpaths.
      exact (! pr12 (pr2 (TransportedTensorComm Duniv H_eso H_ff TC) (x3,x4))).
    }
    etrans.
    2: {
      apply maponpaths.
      rewrite id_right.
      rewrite (functor_id TD).
      simpl.
      rewrite binprod_id.
      apply (! functor_id TD _).
    }
    apply (! id_right _).
  Qed.

  Context (I : C).

  Definition H_pα
    : (functor_ass_disp_cat (IC := I) α αD)
        (H ,, (pr1 (TransportedTensorComm Duniv H_eso H_ff TC) ,, identity _)).
  Proof.
    intros x y z.

    unfold αD.
    unfold TransportedAssociator.

    etrans. {
      apply maponpaths_2.
      exact (! TransportedAssocLeftOnOb x y z).
    }

    assert (p1' : (# TD (id pr1 H x #, (pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (y, z))
                     · (pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (x, TC (y, z))) = TransportedAssocRight ((x,y),z)).
    {
      rewrite <- (functor_id H).
      exact (! TransportedAssocRightOnOb x y z).
    }

    assert (p1 : (nat_z_iso_inv TransportedAssocRight) ((x,y),z)
                 · (# TD (id pr1 H x #, (pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (y, z))
             · (pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (x, TC (y, z))) = identity _).
    {
      use (z_iso_inv_on_right _ _ _ (_,,pr2 TransportedAssocRight ((x,y),z))).
      rewrite id_right.
      exact p1'.
    }

    set (cc := lift_nat_z_iso_along (D,, Duniv) HHH HHH_eso HHH_ff
               (nat_z_iso_comp
       (nat_z_iso_comp TransportedAssocLeft (post_whisker_nat_z_iso α H))
       (nat_z_iso_inv TransportedAssocRight))).

    set (cc1 := (post_whisker_nat_z_iso α H)).
    set (cc0 := TransportedAssocLeft).
    set (cc2 := (nat_z_iso_inv TransportedAssocRight)).
    set (dd := nat_z_iso_comp cc0 (nat_z_iso_comp cc1 cc2)).
    assert (p2' : dd = pre_whisker_nat_z_iso HHH cc).
    {
      use total2_paths_f.
      2: { apply isaprop_is_nat_z_iso. }

      etrans. {
        apply (! lift_nat_trans_along_comm (_,,Duniv) _ HHH_eso HHH_ff _).
      }

      apply (maponpaths (pre_whisker HHH)).
      apply (maponpaths (lift_nat_trans_along (D,, Duniv) HHH HHH_eso HHH_ff)).
      apply nat_trans_comp_assoc.
      apply homset_property.
    }

    set (cc' := lift_nat_z_iso_along (D,, Duniv) HHH HHH_eso HHH_ff
    (nat_z_iso_comp
       (nat_z_iso_comp TransportedAssocLeft (post_whisker_nat_z_iso α H))
       (nat_z_iso_inv TransportedAssocRight)) (HHH ((x,y),z))).

    set (cc1' := (post_whisker_nat_z_iso α H) ((x,y),z)).
    set (cc0' := TransportedAssocLeft ((x,y),z)).
    set (cc2' := (nat_z_iso_inv TransportedAssocRight) ((x,y),z)).
    assert (p2 : cc0' · cc1' · cc2' = cc').
    {
      set (q := toforallpaths _ _ _ (base_paths _ _ (base_paths _ _ p2')) ((x,y),z)).
      refine (_ @ q).
      apply assoc'.
    }

    etrans.
    2: {
      do 2 apply maponpaths_2.
      exact p2.
    }
    clear p2.
    unfold cc0', cc1', cc2'.
    clear cc0' cc1' cc2'.
    rewrite ! assoc'.
    apply maponpaths.
    etrans.
    2: {
      apply maponpaths.
      exact (! p1).
    }
    apply (! id_right _).
  Qed.

  Context {E : category} (Euniv : is_univalent E)
          (TE : functor (E ⊠ E) E)
          (αE : associator TE).

  Context (IE : E).

  Definition precompA
    : disp_functor (precomp_tensorunit_functor Duniv H_eso H_ff TC I TE IE)
                   (functor_ass_disp_cat αD αE)
                   (functor_ass_disp_cat α αE).
  Proof.
    use tpair.
    - use tpair.
      2: intro ; intros ; exact tt.
      exact (λ G GG, functor_ass_composition H_pα GG).
    - split ; intro ; intros ; apply isapropunit.
  Qed.

  Lemma precompA_ff
    : disp_functor_ff precompA.
  Proof.
    intro ; intros.
    apply isweqinclandsurj.
    - do 3 intro.
      assert (p : isaset ( hfiber (λ ff : unit, ♯ precompA ff) y0)).
      {
        use isaset_hfiber ; use isasetaprop ; apply isapropunit.
      }
      use tpair.
      + use total2_paths_f.
        { apply isapropunit. }
        use proofirrelevance.
        use hlevelntosn.
        apply isapropunit.
      + intro ; apply p.
    - intro ; intros.
      apply hinhpr.
      exists tt.
      apply isapropunit.
  Qed.

  Lemma lift_preserves_associator
        {G : functor_tensorunit_cat (TransportedTensor Duniv H_eso H_ff TC) TE (H I) IE}
        ( GG : functor_ass_disp_cat α αE (precomp_tensorunit_functor Duniv H_eso H_ff TC I TE IE G))
    : functor_ass_disp_cat αD αE G.
  Proof.
    intros d1 d2 d3.
    use factor_through_squash.
    { exact (∑ a : C, z_iso (H a) d1). }
    { apply homset_property. }
    2: exact (H_eso d1).
    intros [c1 i1].
    induction (isotoid _ Duniv i1).
    clear i1.

    use factor_through_squash.
    { exact (∑ a : C, z_iso (H a) d2). }
    { apply homset_property. }
    2: exact (H_eso d2).
    intros [c2 i2].
    induction (isotoid _ Duniv i2).
    clear i2.

    use factor_through_squash.
    { exact (∑ a : C, z_iso (H a) d3). }
    { apply homset_property. }
    2: exact (H_eso d3).
    intros [c3 i3].
    induction (isotoid _ Duniv i3).
    clear i3.

    etrans. {
      do 2 apply maponpaths.
      exact (TransportedAssociatorOnOb ((c1,c2), c3)).
    }

    rewrite TransportedAssocLeftOnOb.
    rewrite TransportedAssocRightInvOnOb.

    set (t := GG c1 c2 c3).
    set (ptG := pr112 G).
    set (ptH := pr1 (TransportedTensorComm Duniv H_eso H_ff TC)).
    set (pt_GH := (pr112 (precomp_tensorunit_functor Duniv H_eso H_ff TC I TE IE G))).
    transparent assert (m : (E⟦ pr11 G (H (TC (c1, TC (c2,, c3))))
                                ,  (pr11 G) (TD (H c1, TD (H c2,, H c3)))⟧)).
    {
      apply #(pr11 G).
      refine (_ · _).
      - apply (TransportedTensorComm Duniv H_eso H_ff).
      - apply (#TD).
        use catbinprodmor.
        + apply identity.
          + apply (TransportedTensorComm Duniv H_eso H_ff).
    }
    set (tt := cancel_postcomposition _ _ m t :
           # TE (pt_GH (c1, c2) #, id  pr11 G (H c3))
         · pt_GH (TC (c1, c2), c3)
         · # (functor_composite H (pr1 G)) (α ((c1, c2), c3)) · m
           = αE ((pr11 G (H ( c1)), (pr11 G (H (c2)))), (pr11 G (H (c3))))
                · # TE (id pr11 G (H (c1)) #, pt_GH (c2, c3)) · pt_GH (c1, TC (c2,c3)) · m).

      set (ptF := (TransportedTensorComm Duniv H_eso H_ff TC)).
      assert (pp : pt_GH (c1, c2)
                   = ptG (H c1, H c2) · #(pr11 G) (ptH (c1,c2))).
      {
        apply idpath.
      }

      refine (_ @ tt @ _) ; unfold m ; clear tt.
    + rewrite pp.
      rewrite ! (functor_comp (pr1 G)).
      assert (qq :  pt_GH (TC (c1, c2), c3)
                    = ptG (H (TC (c1,c2)), H c3) · #(pr11 G) (ptH (TC (c1,c2),c3))).
      {
        apply idpath.
      }
      rewrite qq.
      fold ptF.
      rewrite <- (id_right (id (pr11 G) (H c3))).
      rewrite binprod_comp.
      rewrite (functor_comp TE _ _).

      rewrite ! assoc'.
      apply maponpaths.
      rewrite ! assoc.
      rewrite (functor_id H).
      do 4 apply maponpaths_2.
      rewrite <- (functor_id (pr1 G)).
      exact (! pr212 G _ _ (ptF (c1, c2) #, id H c3)).
    + rewrite ! assoc'.
      apply maponpaths.
      assert (qq' :  (pt_GH (c1, TC (c2, c3))
                      = ptG (H c1, H (TC (c2,c3))) · #(pr11 G) (ptH (c1, TC (c2,c3))))).
      {
        apply idpath.
      }
      rewrite qq'.
      fold ptF.
      assert (qq'' :  pt_GH (c2, c3)
                      = ptG (H c2, H c3) · #(pr11 G) (ptH (c2,c3))).
      { apply idpath. }
      rewrite qq''.
      rewrite (! id_right (id (pr11 G) (H c1))).
      rewrite binprod_comp.
      rewrite (functor_comp TE _ _).
      rewrite ! assoc'.
      apply maponpaths.

      etrans. {
        do 2 apply maponpaths.
        rewrite (functor_comp (pr1 G)).
        rewrite assoc.
        apply maponpaths_2.
        rewrite <- (functor_comp (pr1 G)  (ptH (c1, TC (c2, c3)))).
        etrans. {
          apply maponpaths.
          apply (pr12 (pr2 ptF (c1, TC (c2,c3)))).
        }
        apply (functor_id (pr1 G)).
        }
        rewrite id_left.
      etrans. {
        apply maponpaths.
        apply (! pr212 G _ _ ((id H c1 #, pr1 (pr2 ptF (c2,, c3))))).
      }
      unfold functor_tensor_map_dom.
      unfold functor_composite.
      simpl.
      rewrite <- (functor_id (pr1 G)).
      rewrite assoc.
      rewrite <- (functor_comp TE).
      rewrite <- binprod_comp.
      rewrite (functor_id (pr1 G)).
      rewrite id_right.
      rewrite <- (functor_id (pr1 G)).
      rewrite <- (functor_comp (pr1 G)).

      etrans. {
        apply maponpaths_2.
        do 3 apply maponpaths.
        apply (pr12 (pr2 ptF (c2,c3))).
      }
      etrans. {
        apply maponpaths_2.
        do 2 rewrite (functor_id (pr1 G)).
        apply (functor_id TE).
      }
      apply id_left.
  Qed.

  Lemma precompA_eso
    : disp_functor_disp_ess_split_surj precompA.
  Proof.
    intros G GG.
    exists (lift_preserves_associator GG).
    refine (tt,,tt,,_).
    split ; apply isapropunit.
  Qed.

  Definition precomp_associator_is_ff
    : fully_faithful (total_functor precompA).
  Proof.
    use disp_functor_ff_to_total_ff.
    - apply (precomp_tensorunit_is_ff Duniv Euniv).
    - exact precompA_ff.
  Qed.

  Definition precomp_associator_is_eso
    : essentially_surjective (total_functor precompA).
  Proof.
    use disp_functor_eso_to_total_eso.
    - apply (precomp_tensorunit_is_eso Duniv Euniv).
    - exact precompA_eso.
    - use Fibrations.iso_cleaving_category.
      apply is_univalent_total_category.
      + apply is_univalent_functor_category.
        exact Euniv.
      + apply functor_tensorunit_disp_cat_is_univalent.
  Qed.

  Definition precomp_associator_adj_equiv
    : adj_equivalence_of_cats (total_functor precompA).
  Proof.
    apply rad_equivalence_of_cats.
    - apply is_univalent_total_category.
      + apply is_univalent_total_category.
        * apply (is_univalent_functor_category _ _ Euniv).
        * apply is_disp_univalent_functor_tensorunit_disp_cat.
      + apply functor_ass_disp_cat_is_univalent.
    - exact precomp_associator_is_ff.
    - exact precomp_associator_is_eso.
  Defined.

  Definition precomp_associator_catiso
    : catiso (total_category (functor_ass_disp_cat (IC := H I) (ID := IE) TransportedAssociator αE))
             (total_category (functor_ass_disp_cat (IC := I) (ID := IE) α αE)).
  Proof.
    use (adj_equivalence_of_cats_to_cat_iso precomp_associator_adj_equiv _ _).
    - apply is_univalent_total_category.
      + apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)).
      + apply functor_ass_disp_cat_is_univalent.
    - apply is_univalent_total_category.
      + apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)).
      + apply functor_ass_disp_cat_is_univalent.
  Defined.

End RezkAssociator.


Require Export SystemFR.ErasedQuant.

Opaque reducible_values.

(** This file specifies with axioms a model for updates and lookups in trails *)

(** We assume that we have a type `T_tree` that represents a tree of values, together with *)
(** an encoding of their types *)
Parameter T_tree: tree.
Axiom tree_fv: forall tag, pfv T_tree tag = nil.
Axiom wf_tree: wf T_tree 0.
Axiom is_erased_type_tree: is_erased_type T_tree.
#[export]
Hint Resolve tree_fv: fv.
#[export]
Hint Resolve wf_tree: wf.
#[export]
Hint Resolve is_erased_type_tree: erased.

(* We assume we have an empty tree *)
Parameter empty_tree: tree.
Axiom empty_tree_type: [ empty_tree : T_tree ]v.

(** We consider a type `T_key` that represents a sequence of selections in a tree *)
Parameter T_key: tree.
Axiom key_fv: forall tag, pfv T_key tag = nil.
Axiom wf_key: wf T_key 0.
Axiom is_erased_type_key: is_erased_type T_key.
#[export]
Hint Resolve key_fv: fv.
#[export]
Hint Resolve wf_key: wf.
#[export]
Hint Resolve is_erased_type_key: erased.

(** These types have no free variables, so substitutions keep them unchanged *)
Lemma substitute_tree:
  forall l tag, psubstitute T_tree l tag = T_tree.
Proof.
  intros; apply substitute_nothing5; eauto using tree_fv.
Qed.

Lemma substitute_key:
  forall l tag, psubstitute T_key l tag = T_key.
Proof.
  intros; apply substitute_nothing5; eauto using key_fv.
Qed.

(** We consider a `tlookup` function that for a type `A` and a tree `t` looks up a value at the *)
(** root of the tree. If the tag at the root corresponds to type `A`, it returns the value at the *)
(** root. Otherwise, it returns the empty list `tnil` or `tleft uu`. We assume that the type *)
(** `A` that appears in `tlookup` contain the empty list, which is the case for the types `T_top` *)
(** and `List` presented in the paper.  *)
(** tlookup: (A: type) -> T_tree -> A *)
Parameter tlookup: tree -> tree -> tree.

Axiom open_lookup:
  forall k A t rep,
    open k (tlookup A t) rep = tlookup (open k A rep) (open k t rep).

Axiom substitute_lookup:
  forall A t l tag,
    psubstitute (tlookup A t) l tag =
    tlookup (psubstitute A l tag) (psubstitute t l tag).

Axiom wf_lookup:
  forall k A t,
    wf A k ->
    wf t k ->
    wf (tlookup A t) k.
#[export]
Hint Resolve wf_lookup: wf.

Axiom is_erased_term_lookup:
  forall A t,
    is_erased_type A ->
    is_erased_term t ->
    is_erased_term (tlookup A t).
#[export]
Hint Resolve is_erased_term_lookup: erased.

Axiom lookup_type:
  forall A tree,
    [ tleft uu : A ]v ->
    [ tree : T_tree ]v ->
    [ tlookup A tree : A ].

Axiom lookup_onto:
  forall a A,
    [ a : A ]v ->
    exists tree,
      [ tree : T_tree ]v /\
      [ tlookup A tree ≡ a ].

Axiom lookup_fv:
  forall A trail tag,
    pfv (tlookup A trail) tag = pfv A tag ++ pfv trail tag.

(** We also assume we have a function `select`, that uses a sequence of selections to select a *)
(** subtree of a tree *)
(** select: T_key -> T_tree -> T_tree *)
Parameter select: tree -> tree -> tree.

Axiom select_type:
  forall key tree,
    [ key : T_key ]v ->
    [ tree : T_tree ]v ->
    [ select key tree : T_tree ]v.

Axiom evaluate_select:
  forall key trail1 trail2,
    trail1 ~>* trail2 ->
    select key trail1 ~>* select key trail2.

Axiom wf_select:
  forall k t1 t2,
    wf t1 k ->
    wf t2 k ->
    wf (select t1 t2) k.

Axiom psubstitute_select:
  forall t1 t2 l tag,
    psubstitute (select t1 t2) l tag =
    select (psubstitute t1 l tag) (psubstitute t2 l tag).

Axiom open_select:
  forall k t1 t2 rep,
    open k (select t1 t2) rep =
    select (open k t1 rep) (open k t2 rep).

Axiom pfv_select:
  forall t1 t2 tag, pfv (select t1 t2) tag = pfv t1 tag ++ pfv t2 tag.

Axiom is_erased_term_select:
  forall t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    is_erased_term (select t1 t2).

#[export]
Hint Resolve wf_select: wf.
#[export]
Hint Resolve is_erased_term_select: erased.

Lemma open_tdots:
  forall Γ key tree,
    [ key : T_key ]v ->
    [ Γ ⊫ tree : T_tree ] ->
    [ Γ ⊫ select key tree : T_tree ].
Proof.
  unfold open_reducible;
    repeat step || rewrite psubstitute_select ||
           t_instantiate_sat3_nil || rewrite substitute_tree.

  top_level_unfold reduces_to; steps.
  eapply star_backstep_reducible; try apply evaluate_select; eauto;
    repeat step || rewrite pfv_select || list_utils || rewrite substitute_tree in * ||
           apply wf_select || apply is_erased_term_select ||
           (rewrite substitute_nothing5 by (steps; eapply reducible_val_fv; eauto; steps));
    try solve [ eapply reducible_val_fv; eauto; steps ];
    try solve [ eapply reducible_val_wf; eauto; steps ];
    try solve [ eapply reducible_values_erased; eauto; steps ];
    t_closer.

  apply reducible_value_expr; repeat step || list_utils2;
    eauto using select_type.
Qed.

(** prefix specifies for two sequences of selections whether the first is a prefix of the second *)
(** prefix: T_key -> T_key -> Prop *)
Parameter prefix: tree -> tree -> Prop.

(** Finally, `update` takes a tree, a key `k`, another tree, and copies the latter in the first *)
(** tree at at position `k` *)
(** update: T_tree -> T_key -> T_tree -> T_tree *)
Parameter update: tree -> tree -> tree -> tree.

Axiom update_type:
  forall old_tree key tree,
    [ old_tree : T_tree ]v ->
    [ key : T_key ]v ->
    [ tree : T_tree ]v ->
    [ update old_tree key tree : T_tree ]v.

Axiom wf_update:
  forall k t1 t2 t3,
    wf t1 k ->
    wf t2 k ->
    wf t3 k ->
    wf (update t1 t2 t3) k.

Axiom open_update:
  forall t1 t2 t3 k rep,
    open k (update t1 t2 t3) rep =
    update (open k t1 rep) (open k t2 rep) (open k t3 rep).

Axiom psubstitute_update:
  forall t1 t2 t3 l tag,
    psubstitute (update t1 t2 t3) l tag =
    update (psubstitute t1 l tag) (psubstitute t2 l tag) (psubstitute t3 l tag).

Axiom pfv_update:
  forall t1 t2 t3 tag,
    pfv (update t1 t2 t3) tag = pfv t1 tag ++ pfv t2 tag ++ pfv t3 tag.

Axiom is_erased_term_update:
  forall t1 t2 t3,
    is_erased_term t1 ->
    is_erased_term t2 ->
    is_erased_term t3 ->
    is_erased_term (update t1 t2 t3).

(** Updates that happen on selections which are not prefixes of another are commutative *)
Axiom update_commutative:
  forall key1 key2 old_tree tree1 tree2,
    [ key1 : T_key ]v ->
    [ key2 : T_key ]v ->
    [ tree1 : T_tree ]v ->
    [ tree2 : T_tree ]v ->
    [ old_tree : T_tree ]v ->
    ~ prefix key1 key2 ->
    ~ prefix key2 key1 ->
      update (update old_tree key2 tree2) key1 tree1 =
      update (update old_tree key1 tree1) key2 tree2.

(** Selecting at a key after an update gives back the replaced tree *)
Axiom select_update:
  forall key old_tree tree,
    select key (update old_tree key tree) = tree.

#[export]
Hint Resolve pfv_update: pfv.
#[export]
Hint Resolve wf_update: wf.
#[export]
Hint Resolve is_erased_term_update: erased.