(*
  Reduction from:
    Uniform Diophantine Constraint Solvability (H10UC_SAT)
  to:
    Uniform Diophantine Pair Constraint Solvability (H10UPC_SAT)
*)

Require Import List Lia Cantor.
Import ListNotations.

Require Import ssreflect ssrbool ssrfun.

Require Import Undecidability.DiophantineConstraints.H10C.

Set Default Proof Using "Type".
Set Default Goal Selector "!".

(* Uniform Diophantine pairs constraints are of shape:
    (x, y) # (1 + x + y, (y²+y)/2)
   Uniform Diophantine constraints are of shape:
    1 + x + y * y = z

  Idea: We represent 1+x+y²=z as such:
  (where a, b, c, t1, t2 are new variables):
  y(y+1)/2 = a
  a+a+1 = b ( = y(y+1) + 1 = y²+y+1)
  c+y+1 = b (-> c = y²)
  x+c+1 = z (-> z = 1+x+y²)

  This yields these constraints
  (a,a) # (b,t1)
  (c,y) # (b,a)
  (c,x) # (z,t2)

  We use the following renaming scheme:
  <x,0> = x                          (used for x,y,z)
  <x,1> = (x²+x)/2                   (used for a (with y), t2 (with x))
  <x,2> = x²+x+1                     (used for b (with y))
  <x,3> = x²                         (used for c (with y))
  <x,4> = (k²+k)/2 where k=(x²+x)/2  (used for t1 (with y))
*)

Module Argument.

Definition c2_full (x: nat) : { y:nat | y + y = x * S x}.
Proof.
  elim: x; first by exists 0.
  move=> x [y Hy]. exists (y+x+1). nia.
Qed.

#[local] Notation c2 x := (sval (c2_full x)).
#[local] Notation c2_spec x := (svalP (c2_full x)).

(* fresh variable space *)
Notation var x t := (Cantor.to_nat (x, t)).
Opaque Cantor.to_nat Cantor.of_nat.

Section Reduction.
(* The instance of h10uc (which we are reducing from) *)
Context (ucs: list h10uc).

Definition h10uc_to_h10upcs (c : h10uc) : list h10upc :=
  let '(x, y, z) := c in
  let '(a, b, c, t1, t2) := (var y 1, var y 2, var y 3, var y 4, var x 1) in
  let '(x, y, z) := (var x 0, var y 0, var z 0) in
    [((a, a), (b, t1)); ((c, y), (b, a)); ((c, x), (z, t2))].

Definition upcs := flat_map h10uc_to_h10upcs ucs.

Section Transport.
(* The solution to cs *)
Context (φ: nat -> nat).
(* Proof that φ solves ucs *)
Context (Hφ : forall c, In c ucs -> h10uc_sem φ c).

Definition φ' (xn: nat) : nat :=
  match Cantor.of_nat xn with
  | (x, 0) => φ x
  | (x, 1) => c2 (φ x)
  | (x, 2) => φ x * φ x + φ x + 1
  | (x, 3) => φ x * φ x
  | (x, 4) => c2 (c2 (φ x))
  | _ => 0
  end.

Lemma transport : forall c, In c upcs -> h10upc_sem φ' c.
Proof using Hφ.
  apply /Forall_forall /Forall_flat_map.
  move: Hφ => /Forall_forall.
  apply: Forall_impl => - [[x y] z] /= ?.
  constructor; [|constructor; [|constructor]]; last done.
  all: rewrite /φ' /= ?Cantor.cancel_of_to ?(c2_spec _); lia.
Qed.

End Transport.

Section InverseTransport.
(* The solution to f(cs) (f is the reduction function) *)
Context (φ': nat -> nat).
(* Proof that φ' solves upcs *)
Context (Hφ' : forall c, In c upcs -> h10upc_sem φ' c).

Definition φ (n:nat) : nat := φ' (var n 0).

Lemma inverse_transport : forall c, In c ucs -> h10uc_sem φ c.
Proof using Hφ'.
  apply /Forall_forall.
  move: Hφ' => /Forall_forall /Forall_flat_map.
  apply: Forall_impl => - [[x y] z] /=.
  move=> /Forall_cons_iff [+] /Forall_cons_iff [+] /Forall_cons_iff [+ _].
  rewrite /φ /=. nia.
Qed.

End InverseTransport.
End Reduction.
End Argument.

Require Import Undecidability.Synthetic.Definitions.

(* Square Diophantine Constraint Solvability many-one reduces to Uniform Diophantine Constraint Solvability *)
Theorem reduction : H10UC_SAT ⪯ H10UPC_SAT.
Proof.
  exists Argument.upcs. split.
  - intros [φ Hφ]. exists (Argument.φ' φ). now apply Argument.transport.
  - intros [φ' Hφ']. exists (Argument.φ φ'). now apply Argument.inverse_transport.
Qed.


(** * ImpCEvalFun: Evaluation Function for Imp *)

(** We saw in the [Imp] chapter how a naive approach to defining a
    function representing evaluation for Imp runs into difficulties.
    There, we adopted the solution of changing from a functional to a
    relational definition of evaluation.  In this optional chapter, we
    consider strategies for getting the functional approach to
    work. *)

(* ################################################################# *)
(** * A Broken Evaluator *)

Require Import Coq.omega.Omega.
Require Import Coq.Arith.Arith.
Require Import Imp.
Require Import Maps.

(** Here was our first try at an evaluation function for commands,
    omitting [WHILE]. *)

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

(** As we remarked in chapter [Imp], in a traditional functional
    programming language like ML or Haskell we could write the WHILE
    case as follows:

    | WHILE b1 DO c1 END => if (beval st b1) then ceval_step1 st (c1;;
        WHILE b1 DO c1 END) else st

    Coq doesn't accept such a definition ([Error: Cannot guess
    decreasing argument of fix]) because the function we want to
    define is not guaranteed to terminate. Indeed, the changed
    [ceval_step1] function applied to the [loop] program from [Imp.v]
    would never terminate. Since Coq is not just a functional
    programming language, but also a consistent logic, any potentially
    non-terminating function needs to be rejected. Here is an
    invalid(!) Coq program showing what would go wrong if Coq allowed
    non-terminating recursive functions:

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

    That is, propositions like [False] would become
    provable (e.g., [loop_false 0] would be a proof of [False]), which
    would be a disaster for Coq's logical consistency.

    Thus, because it doesn't terminate on all inputs, the full version
    of [ceval_step1] cannot be written in Coq -- at least not without
    one additional trick... *)

(* ################################################################# *)
(** * A Step-Indexed Evaluator *)

(** The trick we need is to pass an _additional_ parameter to the
    evaluation function that tells it how long to run.  Informally, we
    start the evaluator with a certain amount of "gas" in its tank,
    and we allow it to run until either it terminates in the usual way
    _or_ it runs out of gas, at which point we simply stop evaluating
    and say that the final result is the empty memory.  (We could also
    say that the result is the current state at the point where the
    evaluator runs out fo gas -- it doesn't really matter because the
    result is going to be wrong in either case!) *)

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_state
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          t_update st l (aeval st a1)
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.

(** _Note_: It is tempting to think that the index [i] here is
    counting the "number of steps of evaluation."  But if you look
    closely you'll see that this is not the case: for example, in the
    rule for sequencing, the same [i] is passed to both recursive
    calls.  Understanding the exact way that [i] is treated will be
    important in the proof of [ceval__ceval_step], which is given as
    an exercise below.

    One thing that is not so nice about this evaluator is that we
    can't tell, from its result, whether it stopped because the
    program terminated normally or because it ran out of gas.  Our
    next version returns an [option state] instead of just a [state],
    so that we can distinguish between normal and abnormal
    termination. *)

Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (t_update st l (aeval st a1))
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.

(** We can improve the readability of this version by introducing a
    bit of auxiliary notation to hide the plumbing involved in
    repeatedly matching against optional states. *)

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (t_update st l (aeval st a1))
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

(* Compute
     (test_ceval empty_state
         (X ::= ANum 2;;
          IFB BLe (AId X) (ANum 1)
            THEN Y ::= ANum 3
            ELSE Z ::= ANum 4
          FI)).
   ====>
      Some (2, 0, 4)   *)

(** **** Exercise: 2 stars, recommended (pup_to_n)  *)
(** Write an Imp program that sums the numbers from [1] to
   [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y].  Make sure
   your solution satisfies the test that follows. *)

Definition pup_to_n : com
  (* REPLACE THIS LINE WITH   := _your_definition_ . *) . Admitted.

(*
Example pup_to_n_1 :
  test_ceval (t_update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.
*)
(** [] *)

(** **** Exercise: 2 stars, optional (peven)  *)
(** Write a [While] program that sets [Z] to [0] if [X] is even and
    sets [Z] to [1] otherwise.  Use [ceval_test] to test your
    program. *)

(* FILL IN HERE *)
(** [] *)

(* ################################################################# *)
(** * Relational vs. Step-Indexed Evaluation *)

(** As for arithmetic and boolean expressions, we'd hope that
    the two alternative definitions of evaluation would actually
    amount to the same thing in the end.  This section shows that this
    is the case. *)

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      c / st \\ st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].

  - (* i = 0 -- contradictory *)
    intros c st st' H. inversion H.

  - (* i = S i' *)
    intros c st st' H.
    destruct c;
           simpl in H; inversion H; subst; clear H.
      + (* SKIP *) apply E_Skip.
      + (* ::= *) apply E_Ass. reflexivity.

      + (* ;; *)
        destruct (ceval_step st c1 i') eqn:Heqr1.
        * (* Evaluation of r1 terminates normally *)
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        * (* Otherwise -- contradiction *)
          inversion H1.

      + (* IFB *)
        destruct (beval st b) eqn:Heqr.
        * (* r = true *)
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        * (* r = false *)
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.

      + (* WHILE *) destruct (beval st b) eqn :Heqr.
        * (* r = true *)
         destruct (ceval_step st c i') eqn:Heqr1.
         { (* r1 = Some s *)
           apply E_WhileLoop with s. rewrite Heqr.
           reflexivity.
           apply IHi'. rewrite Heqr1. reflexivity.
           apply IHi'. simpl in H1. assumption. }
         { (* r1 = None *) inversion H1. }
        * (* r = false *)
          inversion H1.
          apply E_WhileEnd.
          rewrite <- Heqr. subst. reflexivity.  Qed.

(** **** Exercise: 4 stars (ceval_step__ceval_inf)  *)
(** Write an informal proof of [ceval_step__ceval], following the
    usual template.  (The template for case analysis on an inductively
    defined value should look the same as for induction, except that
    there is no induction hypothesis.)  Make your proof communicate
    the main ideas to a human reader; do not simply transcribe the
    steps of the formal proof.

(* FILL IN HERE *)
[]
*)

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  - (* i1 = 0 *)
    simpl in Hceval. inversion Hceval.
  - (* i1 = S i1' *)
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    destruct c.
    + (* SKIP *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ::= *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ;; *)
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* st1'o = None *)
        inversion Hceval.

    + (* IFB *)
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval;
        assumption.

    + (* WHILE *)
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* i1'o = None *)
        simpl in Hceval. inversion Hceval.  Qed.

(** **** Exercise: 3 stars, recommended (ceval__ceval_step)  *)
(** Finish the following proof.  You'll need [ceval_step_more] in a
    few places, as well as some basic facts about [<=] and [plus]. *)

Theorem ceval__ceval_step: forall c st st',
      c / st \\ st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem ceval_and_ceval_step_coincide: forall c st st',
      c / st \\ st'
  <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

(* ################################################################# *)
(** * Determinism of Evaluation Again *)

(** Using the fact that the relational and step-indexed definition of
    evaluation are the same, we can give a slicker proof that the
    evaluation _relation_ is deterministic. *)

Theorem ceval_deterministic' : forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega.  Qed.

(** $Date: 2016-07-13 12:41:41 -0400 (Wed, 13 Jul 2016) $ *)


(** Borrowed from Pierce's "Software Foundations" *)

Require Import Arith Arith.EqNat.
Require Import Omega.

Inductive id : Type :=
  Id : nat -> id.

Reserved Notation "m i<= n" (at level 70, no associativity).
Reserved Notation "m i>  n" (at level 70, no associativity).
Reserved Notation "m i<  n" (at level 70, no associativity).

Inductive le_id : id -> id -> Prop :=
  le_conv : forall n m, n <= m -> (Id n) i<= (Id m)
where "n i<= m" := (le_id n m).

Inductive lt_id : id -> id -> Prop :=
  lt_conv : forall n m, n < m -> (Id n) i< (Id m)
where "n i< m" := (lt_id n m).

Inductive gt_id : id -> id -> Prop :=
  gt_conv : forall n m, n > m -> (Id n) i> (Id m)
where "n i> m" := (gt_id n m).

Notation "n i<= m" := (le_id n m).
Notation "n i>  m" := (gt_id n m).
Notation "n i<  m" := (lt_id n m).

Ltac prove_with th :=
  intros;
  repeat (match goal with H: id |- _ => destruct H end);
  match goal with n: nat, m: nat |- _ => set (th n m) end;
  repeat match goal with H: _ + {_} |- _ => inversion_clear H end;
  try match goal with H: {_} + {_} |- _ => inversion_clear H end;
  repeat
    match goal with
      H: ?n <  ?m |-  _                + {Id ?n i< Id ?m}  => right
    | H: ?n <  ?m |-  _                + {_}               => left
    | H: ?n >  ?m |-  _                + {Id ?n i> Id ?m}  => right
    | H: ?n >  ?m |-  _                + {_}               => left
    | H: ?n <  ?m |- {_}               + {Id ?n i< Id ?m}  => right
    | H: ?n <  ?m |- {Id ?n i< Id ?m}  + {_}               => left
    | H: ?n >  ?m |- {_}               + {Id ?n i> Id ?m}  => right
    | H: ?n >  ?m |- {Id ?n i> Id ?m}  + {_}               => left
    | H: ?n =  ?m |-  _                + {Id ?n =  Id ?m}  => right
    | H: ?n =  ?m |-  _                + {_}               => left
    | H: ?n =  ?m |- {_}               + {Id ?n =  Id ?m}  => right
    | H: ?n =  ?m |- {Id ?n =  Id ?m}  + {_}               => left
    | H: ?n <> ?m |-  _                + {Id ?n <> Id ?m}  => right
    | H: ?n <> ?m |-  _                + {_}               => left
    | H: ?n <> ?m |- {_}               + {Id ?n <> Id ?m}  => right
    | H: ?n <> ?m |- {Id ?n <> Id ?m}  + {_}               => left

    | H: ?n <= ?m |-  _                + {Id ?n i<= Id ?m} => right
    | H: ?n <= ?m |-  _                + {_}               => left
    | H: ?n <= ?m |- {_}               + {Id ?n i<= Id ?m} => right
    | H: ?n <= ?m |- {Id ?n i<= Id ?m} + {_}               => left
    end;
  try (constructor; assumption); congruence.

Lemma lt_eq_lt_id_dec: forall (id1 id2 : id), {id1 i< id2} + {id1 = id2} + {id2 i< id1}.
Proof. prove_with lt_eq_lt_dec. Qed.

Lemma gt_eq_gt_id_dec: forall (id1 id2 : id), {id1 i> id2} + {id1 = id2} + {id2 i> id1}.
Proof. prove_with gt_eq_gt_dec. Qed.

Lemma le_gt_id_dec : forall id1 id2 : id, {id1 i<= id2} + {id1 i> id2}.
Proof. prove_with le_gt_dec. Qed.

Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}.
Proof.
  intros. set (eq_nat_is_eq n m). inversion i. set (eq_nat_decide n m). inversion s.
    apply H in H1. left. assumption. right. auto.
Qed.

Lemma id_eq_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof. prove_with eq_dec. Qed.

Lemma eq_id : forall (T:Type) x (p q:T), (if id_eq_dec x x then p else q) = p.
Proof.
  intros. destruct (id_eq_dec x x). reflexivity. exfalso; auto.
Qed.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y -> (if id_eq_dec x y then p else q) = q.
Proof.
 intros. destruct (id_eq_dec x y). contradiction. reflexivity.
Qed.

Lemma lt_gt_id_false : forall id1 id2 : id,
  id1 i> id2 -> id2 i> id1 -> False.
Proof.
  intros id1 id2 H1 H2.
  inversion H1. inversion H2.
  rewrite <-H5 in H3. rewrite <-H6 in H0.
  inversion H3. inversion H0. omega.
Qed.

Lemma le_gt_id_false : forall id1 id2 : id,
  id2 i<= id1 -> id2 i> id1 -> False.
Proof.
  intros id1 id2 H1 H2.
  inversion H1. inversion H2.
  rewrite <-H5 in H0. rewrite <-H6 in H3.
  inversion H3. inversion H0. omega.
Qed.

Lemma le_lt_eq_id_dec : forall id1 id2 : id,
  id1 i<= id2 -> {id1 = id2} + {id2 i> id1}.
Proof.
  intros id1 id2 H. remember (gt_eq_gt_id_dec id1 id2). inversion s. inversion H0.
    apply (lt_gt_id_false id1 id2) in H1. contradiction.
      inversion H1. inversion H. rewrite <- H3 in H6. rewrite <-H4 in H7. inversion H6. inversion H7. omega.
      left. assumption.
      right. assumption.
Qed.

Lemma neq_lt_gt_id_dec : forall id1 id2 : id,
  id1 <> id2 -> {id1 i> id2} + {id2 i> id1}.
Proof.
  intros id1 id2 H. unfold not in H. remember (le_gt_id_dec id1 id2).
    inversion s. apply le_lt_eq_id_dec in H0. inversion H0. contradiction.
       right. assumption. left. assumption.
Qed.

Lemma eq_gt_id_false : forall id1 id2 : id,
  id1 = id2 -> id1 i> id2 -> False.
Proof.
  intros id1 id2 H1 H2.
  inversion H2. rewrite <-H3 in H1. rewrite <-H0 in H1. inversion H1. omega.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Coq.extraction.Extraction.
Require Import Arith.
Require Import List.

(**** A few tests for the extraction mechanism ****)

(* Ideally, we should monitor the extracted output
   for changes, but this is painful. For the moment,
   we just check for failures of this script. *)

(*** STANDARD EXAMPLES *)

(** Functions. *)

Definition idnat (x:nat) := x.
Extraction idnat.
(* let idnat x = x *)

Definition id (X:Type) (x:X) := x.
Extraction id. (* let id x = x *)
Definition id' := id Set nat.
Extraction id'. (* type id' = nat *)

Definition test2 (f:nat -> nat) (x:nat) := f x.
Extraction test2.
(* let test2 f x = f x *)

Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat.
Extraction test3.
(* let test3 f x = f x __ *)

Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g.
Extraction test4.
(* let test4 f x g = f g *)

Definition test5 := (1, 0).
Extraction test5.
(* let test5 = Pair ((S O), O) *)

Definition cf (x:nat) (_:x <= 0) := S x.
Extraction NoInline cf.
Definition test6 := cf 0 (le_n 0).
Extraction test6.
(* let test6 = cf O *)

Definition test7 := (fun (X:Set) (x:X) => x) nat.
Extraction test7.
(* let test7 x = x *)

Definition d (X:Type) := X.
Extraction d. (* type 'x d = 'x *)
Definition d2 := d Set.
Extraction d2. (* type d2 = __ d *)
Definition d3 (x:d Set) := 0.
Extraction d3. (* let d3 _ = O *)
Definition d4 := d nat.
Extraction d4. (* type d4 = nat d *)
Definition d5 := (fun x:d Type => 0) Type.
Extraction d5.  (* let d5 = O *)
Definition d6 (x:d Type) := x.
Extraction d6.  (* type 'x d6 = 'x *)

Definition test8 := (fun (X:Type) (x:X) => x) Set nat.
Extraction test8. (* type test8 = nat *)

Definition test9 := let t := nat in id Set t.
Extraction test9.  (* type test9 = nat *)

Definition test10 := (fun (X:Type) (x:X) => 0) Type Type.
Extraction test10. (* let test10 = O *)

Definition test11 := let n := 0 in let p := S n in S p.
Extraction test11. (* let test11 = S (S O) *)

Definition test12 := forall x:forall X:Type, X -> X, x Type Type.
Extraction test12.
(* type test12 = (__ -> __ -> __) -> __ *)

Definition test13 := match @left True True I with
                     | left x => 1
                     | right x => 0
                     end.
Extraction test13. (* let test13 = S O *)

(** example with more arguments that given by the type *)

Definition test19 :=
  nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0)
    (fun (n:nat) (f:nat -> nat) => f) 0 0.
Extraction test19.
(* let test19 =
  let rec f = function
    | O -> (fun n0 -> O)
    | S n0 -> f n0
  in f O O
*)

(** casts *)

Definition test20 := True:Type.
Extraction test20.
(* type test20 = __ *)

(** Simple inductive type and recursor. *)

Extraction nat.
(*
type nat =
  | O
  | S of nat
*)

Extraction sumbool_rect.
(*
let sumbool_rect f f0 = function
  |  Left -> f __
  | Right -> f0 __
*)

(** Less simple inductive type. *)

Inductive c (x:nat) : nat -> Set :=
  | refl : c x x
  | trans : forall y z:nat, c x y -> y <= z -> c x z.
Extraction c.
(*
type c =
  | Refl
  | Trans of nat * nat * c
*)

Definition Ensemble (U:Type) := U -> Prop.
Definition Empty_set (U:Type) (x:U) := False.
Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y.

Inductive Finite (U:Type) : Ensemble U -> Type :=
  | Empty_is_finite : Finite U (Empty_set U)
  | Union_is_finite :
      forall A:Ensemble U,
        Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x).
Extraction Finite.
(*
type 'u finite =
  | Empty_is_finite
  | Union_is_finite of 'u finite * 'u
*)

(** Mutual Inductive *)

Inductive tree : Set :=
    Node : nat -> forest -> tree
with forest : Set :=
  | Leaf : nat -> forest
  | Cons : tree -> forest -> forest.

Extraction tree.
(*
type tree =
  | Node of nat * forest
and forest =
  | Leaf of nat
  | Cons of tree * forest
*)

Fixpoint tree_size (t:tree) : nat :=
  match t with
  | Node a f => S (forest_size f)
  end

 with forest_size (f:forest) : nat :=
  match f with
  | Leaf b => 1
  | Cons t f' => tree_size t + forest_size f'
  end.

Extraction tree_size.
(*
let rec tree_size = function
  | Node (a, f) -> S (forest_size f)
and forest_size = function
  | Leaf b -> S O
  | Cons (t, f') -> plus (tree_size t) (forest_size f')
*)

(** Eta-expansions of inductive constructor *)

Inductive titi : Set :=
    tata : nat -> nat -> nat -> nat -> titi.
Definition test14 := tata 0.
Extraction test14.
(* let test14 x x0 x1 = Tata (O, x, x0, x1) *)
Definition test15 := tata 0 1.
Extraction test15.
(* let test15 x x0 = Tata (O, (S O), x, x0) *)

Inductive eta : Type :=
    eta_c : nat -> Prop -> nat -> Prop -> eta.
Extraction eta_c.
(*
type eta =
  | Eta_c of nat * nat
*)
Definition test16 := eta_c 0.
Extraction test16.
(* let test16 x = Eta_c (O, x) *)
Definition test17 := eta_c 0 True.
Extraction test17.
(* let test17 x = Eta_c (O, x) *)
Definition test18 := eta_c 0 True 0.
Extraction test18.
(* let test18 _ = Eta_c (O, O) *)

(** Example of singleton inductive type *)

Inductive bidon (A:Prop) (B:Type) : Type :=
    tb : forall (x:A) (y:B), bidon A B.
Definition fbidon (A B:Type) (f:A -> B -> bidon True nat)
  (x:A) (y:B) := f x y.
Extraction bidon.
(* type 'b bidon = 'b *)
Extraction tb.
(* tb : singleton inductive constructor *)
Extraction fbidon.
(* let fbidon f x y =
  f x y
*)

Definition fbidon2 := fbidon True nat (tb True nat).
Extraction fbidon2. (* let fbidon2 y = y *)
Extraction NoInline fbidon.
Extraction fbidon2.
(* let fbidon2 y = fbidon (fun _ x -> x) __ y *)

(* NB: first argument of fbidon2 has type [True], so it disappears. *)

(** mutual inductive on many sorts *)

Inductive test_0 : Prop :=
    ctest0 : test_0
with test_1 : Set :=
    ctest1 : test_0 -> test_1.
Extraction test_0.
(* test0 : logical inductive *)
Extraction test_1.
(*
type test1 =
  | Ctest1
*)

(** logical singleton *)

Extraction eq.
(* eq : logical inductive *)
Extraction eq_rect.
(* let eq_rect x f y =
  f
*)

(** No more propagation of type parameters. Obj.t instead. *)

Inductive tp1 : Type :=
    T : forall (C:Set) (c:C), tp2 -> tp1
with tp2 : Type :=
    T' : tp1 -> tp2.
Extraction tp1.
(*
type tp1 =
  | T of __ * tp2
and tp2 =
  | T' of tp1
*)

Inductive tp1bis : Type :=
    Tbis : tp2bis -> tp1bis
with tp2bis : Type :=
    T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis.
Extraction tp1bis.
(*
type tp1bis =
  | Tbis of tp2bis
and tp2bis =
  | T'bis of __ * tp1bis
*)

(** Strange inductive type. *)

Inductive Truc : Set -> Type :=
  | chose : forall A:Set, Truc A
  | machin : forall A:Set, A -> Truc bool -> Truc A.
Extraction Truc.
(*
type 'x truc =
  | Chose
  | Machin of 'x * bool truc
*)

(** Dependant type over Type *)

Definition test24 := sigT (fun a:Set => option a).
Extraction test24.
(* type test24 = (__, __ option) sigT *)

(** Coq term non strongly-normalizable after extraction *)

Require Import Gt.
Definition loop (Ax:Acc gt 0) :=
  (fix F (a:nat) (b:Acc gt a) {struct b} : nat :=
     F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 Ax.
Extraction loop.
(* let loop _ =
  let rec f a =
    f (S a)
  in f O
*)

(*** EXAMPLES NEEDING OBJ.MAGIC *)

(** False conversion of type: *)

Lemma oups : forall H:nat = list nat, nat -> nat.
intros.
generalize H0; intros.
rewrite H in H1.
case H1.
exact H0.
intros.
exact n.
Defined.
Extraction oups.
(*
let oups h0 =
  match Obj.magic h0 with
    | Nil -> h0
    | Cons0 (n, l) -> n
*)

(** hybrids *)

Definition horibilis (b:bool) :=
  if b as b return (if b then Type else nat) then Set else 0.
Extraction horibilis.
(*
let horibilis = function
  | True -> Obj.magic __
  | False -> Obj.magic O
*)

Definition PropSet (b:bool) := if b then Prop else Set.
Extraction PropSet. (* type propSet = __ *)

Definition natbool (b:bool) := if b then nat else bool.
Extraction natbool. (* type natbool = __ *)

Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true.
Extraction zerotrue.
(*
let zerotrue = function
  | True -> Obj.magic O
  | False -> Obj.magic True
*)

Definition natProp (b:bool) := if b return Type then nat else Prop.

Definition natTrue (b:bool) := if b return Type then nat else True.

Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True.
Extraction zeroTrue.
(*
let zeroTrue = function
  | True -> Obj.magic O
  | False -> Obj.magic __
*)

Definition natTrue2 (b:bool) := if b return Type then nat else True.

Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I.
Extraction zeroprop.
(*
let zeroprop = function
  | True -> Obj.magic O
  | False -> Obj.magic __
*)

(** polymorphic f applied several times *)

Definition test21 := (id nat 0, id bool true).
Extraction test21.
(* let test21 = Pair ((id O), (id True)) *)

(** ok *)

Definition test22 :=
  (fun f:forall X:Type, X -> X => (f nat 0, f bool true))
    (fun (X:Type) (x:X) => x).
Extraction test22.
(* let test22 =
  let f = fun x -> x in Pair ((f O), (f True)) *)

(* still ok via optim beta -> let *)

Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true).
Extraction test23.
(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *)

(* problem: fun f -> (f 0, f true) not legal in ocaml *)
(* solution: magic ... *)

(** Dummy constant __ can be applied.... *)

Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0).
Extraction f.
(* let f x y =
  y (x O)
*)

Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true).
Extraction NoInline f.
Extraction f_prop.
(* let f_prop =
  f (Obj.magic __) (fun _ -> True)
*)

Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true).
Extraction f_arity.
(* let f_arity =
  f (Obj.magic __) (fun _ -> True)
*)

Definition f_normal :=
  f nat (fun x => x) (fun x => match x with
                               | O => true
                               | _ => false
                               end).
Extraction f_normal.
(* let f_normal =
  f (fun x -> x) (fun x -> match x with
                             | O -> True
                             | S n -> False)
*)

(* inductive with magic needed *)

Inductive Boite : Set :=
    boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite.
Extraction Boite.
(*
type boite =
  | Boite of bool * __
*)

Definition boite1 := boite true 0.
Extraction boite1.
(* let boite1 = Boite (True, (Obj.magic O)) *)

Definition boite2 := boite false (0, 0).
Extraction boite2.
(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *)

Definition test_boite (B:Boite) :=
  match B return nat with
  | boite true n => n
  | boite false n => fst n + snd n
  end.
Extraction test_boite.
(*
let test_boite = function
  | Boite (b0, n) ->
      (match b0 with
         | True -> Obj.magic n
         | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n)))
*)

(* singleton inductive with magic needed *)

Inductive Box : Type :=
    box : forall A:Set, A -> Box.
Extraction Box.
(* type box = __ *)

Definition box1 := box nat 0.
Extraction box1. (* let box1 = Obj.magic O *)

(* applied constant, magic needed *)

Definition idzarb (b:bool) (x:if b then nat else bool) := x.
Definition zarb := idzarb true 0.
Extraction NoInline idzarb.
Extraction zarb.
(* let zarb = Obj.magic idzarb True (Obj.magic O) *)

(** function of variable arity. *)
(** Fun n = nat -> nat -> ... -> nat *)

Fixpoint Fun (n:nat) : Set :=
  match n with
  | O => nat
  | S n => nat -> Fun n
  end.

Fixpoint Const (k n:nat) {struct n} : Fun n :=
  match n as x return Fun x with
  | O => k
  | S n => fun p:nat => Const k n
  end.

Fixpoint proj (k n:nat) {struct n} : Fun n :=
  match n as x return Fun x with
  | O => 0 (* ou assert false ....*)
  | S n =>
      match k with
      | O => fun x => Const x n
      | S k => fun x => proj k n
      end
  end.

Definition test_proj := proj 2 4 0 1 2 3.

Eval compute in test_proj.

Recursive Extraction test_proj.

(*** TO SUM UP: ***)

Module Everything.
 Definition idnat := idnat.
 Definition id := id.
 Definition id' := id'.
 Definition test2 := test2.
 Definition test3 := test3.
 Definition test4 := test4.
 Definition test5 := test5.
 Definition test6 := test6.
 Definition test7 := test7.
 Definition d := d.
 Definition d2 := d2.
 Definition d3 := d3.
 Definition d4 := d4.
 Definition d5 := d5.
 Definition d6 := d6.
 Definition test8 := test8.
 Definition test9 := test9.
 Definition test10 := test10.
 Definition test11 := test11.
 Definition test12 := test12.
 Definition test13 := test13.
 Definition test19 := test19.
 Definition test20 := test20.
 Definition nat := nat.
 Definition sumbool_rect := sumbool_rect.
 Definition c := c.
 Definition Finite := Finite.
 Definition tree := tree.
 Definition tree_size := tree_size.
 Definition test14 := test14.
 Definition test15 := test15.
 Definition eta_c := eta_c.
 Definition test16 := test16.
 Definition test17 := test17.
 Definition test18 := test18.
 Definition bidon := bidon.
 Definition tb := tb.
 Definition fbidon := fbidon.
 Definition fbidon2 := fbidon2.
 Definition test_0 := test_0.
 Definition test_1 := test_1.
 Definition eq_rect := eq_rect.
 Definition tp1 := tp1.
 Definition tp1bis := tp1bis.
 Definition Truc := Truc.
 Definition oups := oups.
 Definition test24 := test24.
 Definition loop := loop.
 Definition horibilis := horibilis.
 Definition PropSet := PropSet.
 Definition natbool := natbool.
 Definition zerotrue := zerotrue.
 Definition zeroTrue := zeroTrue.
 Definition zeroprop := zeroprop.
 Definition test21 := test21.
 Definition test22 := test22.
 Definition test23 := test23.
 Definition f := f.
 Definition f_prop := f_prop.
 Definition f_arity := f_arity.
 Definition f_normal := f_normal.
 Definition Boite := Boite.
 Definition boite1 := boite1.
 Definition boite2 := boite2.
 Definition test_boite := test_boite.
 Definition Box := Box.
 Definition box1 := box1.
 Definition zarb := zarb.
 Definition test_proj := test_proj.
End Everything.

(* Extraction "test_extraction.ml" Everything. *)
Recursive Extraction Everything.
(* Check that the previous OCaml code is compilable *)
Extraction TestCompile Everything.

Extraction Language Haskell.
(* Extraction "Test_extraction.hs" Everything. *)
Recursive Extraction Everything.

Extraction Language Scheme.
(* Extraction "test_extraction.scm" Everything. *)
Recursive Extraction Everything.

(*** Finally, a test more focused on everyday's life situations ***)

Require Import ZArith.

Extraction Language OCaml.
Recursive Extraction Z_modulo_2 Zdiv_eucl_exist.
Extraction TestCompile Z_modulo_2 Zdiv_eucl_exist.


(* (c) P. Casteran *)

Set Implicit Arguments.
Require Export List.

(* potentialy infinite trees with internal nodes labeled with type A *)

CoInductive LTree (A:Type) : Type :=
  LLeaf : LTree A
| LBin : A -> LTree A -> LTree A -> LTree A.

Arguments LLeaf {A}.

(** Decomposition lemmas *)

Definition LTree_decomp {A:Type} (t: LTree A) : LTree A
  := match t with
         LLeaf => LLeaf
       | LBin a t1 t2 => (LBin  a t1 t2)
       end.

Lemma LTree_decompose {A: Type} :
   forall t: LTree A, t = LTree_decomp t.
Proof.
 destruct t; reflexivity.
Qed.

Ltac  LTree_unfold term :=
  apply trans_equal with (1 := LTree_decompose term).

Definition is_LLeaf {A:Type} (t:LTree A) : Prop :=
  match t with
  | LLeaf => True
  | _ => False
  end.

Definition L_root {A:Type} (t:LTree A) : option A :=
  match t with
  | LLeaf => None
  | LBin r _ _ => Some r
  end.

Definition L_left_son {A:Type} (t:LTree A) : option (LTree A) :=
  match t with
  | LLeaf => None
  | LBin _ t1 _ => Some t1
  end.

Definition L_right_son {A:Type} (t:LTree A) : option (LTree A) :=
  match t with
  | LLeaf => None
  | LBin _ _ t2 => Some t2
  end.

Inductive direction : Type :=
  | d0 : direction (* left *)
  | d1 : direction (* right *).

Definition path := list direction.

(* The subtree at path p *)

Fixpoint L_subtree {A:Type} (p:path) (t:LTree A) {struct p} :
 option (LTree A) :=
  match p with
  | nil => Some t
  | d0 :: p' =>
      match t with
      | LLeaf => None
      | LBin a t1 t2 => L_subtree p' t1
      end
  | d1 :: p' =>
      match t with
      | LLeaf => None
      | LBin a t1 t2 => L_subtree p' t2
      end
  end.

(* the label at path p *)

Definition LTree_label {A:Type} (t:LTree A) (p:path) :
  option A :=
  match L_subtree p t with
  | None => None
  | Some t' =>
      match t' with
      | LLeaf => None
      | LBin x _ _ => Some x
      end
  end.

Lemma LTree_label_rw_leaf {A: Type} :
 forall  (d:direction) (p:path),
   LTree_label (LLeaf (A:=A)) (d :: p) = None.
Proof.
  unfold LTree_label in |- *; intros  d p; case d; simpl in |- *; auto.
Qed.

Lemma LTree_label_rw_root_bin {A: Type}:
 forall  (a:A) (t1 t2:LTree A),
   LTree_label (LBin a t1 t2) nil = Some a .
Proof.
  unfold LTree_label in |- *; simpl in |- *; auto.
Qed.

Lemma LTree_label_rw_root_leaf  {A: Type}:
   LTree_label (LLeaf (A:=A)) nil = None.
Proof.
  unfold LTree_label in |- *; simpl in |- *; auto.
Qed.

Lemma LTree_label_rw0 {A: Type}:
 forall  (a:A) (t1 t2:LTree A) (p:path),
   LTree_label (LBin a t1 t2) (d0 :: p) = LTree_label t1 p.
Proof.
  unfold LTree_label in |- *; simpl in |- *; auto.
Qed.

Lemma LTree_label_rw1 {A:Type} :
 forall  (a:A) (t1 t2:LTree A) (p:path),
   LTree_label (LBin a t1 t2) (d1 :: p) = LTree_label t2 p.
Proof.
  unfold LTree_label in |- *; simpl in |- *; auto.
Qed.


(*
Proof that strong function extensionality follows
from naive function extensionality.

We create a typeclass carrying a proof of naive functionality,
and provide a version of function extensionality that is an
adjoint equivalence with the cannonical happly.

To use, simply provide an instance of FunExt in the context.
*)

From IWTypes Require Adjointification.

Class FunExt := funext_raw
  : forall {A B} (f g : forall a : A, B a), (forall a, f a = g a) -> f = g.

Section funext.
Context {FunExt : FunExt}.
Context {A} {B : A -> Type}.
Implicit Types f g : forall a, B a.

Definition happly {f g} (feq : f = g) : forall a, f a = g a
  := match feq in (_ = g) return forall a, f a = g a
     with eq_refl => fun a => eq_refl end.

Definition funext {f g} (hom : forall a, f a = g a) : f = g
  := eq_trans (eq_sym (funext_raw f f (happly eq_refl))) (funext_raw f g hom).

Definition funext_comp {f g} (feq : f = g)
  : funext (happly feq) = feq
  := match feq return funext (happly feq) = feq
     with eq_refl => eq_trans_sym_inv_l (funext_raw f f (happly eq_refl)) end.
End funext.

Section funext_app.
Context {FunExt : FunExt}.
Context {A} {B : A -> Type}.
Implicit Types f g : forall a, B a.

Definition funext_contract {f g} (hom : forall a, f a = g a)
  : existT _ f (fun a => eq_refl) = existT _ g hom
  := f_equal
     (fun r => existT (fun g => forall a, f a = g a)
        (fun a => projT1 (r a)) (fun a => projT2 (r a)))
     (funext (fun a =>
      match hom a as homa in (_ = ga)
      return existT _ (f a) eq_refl = existT _ ga homa
      with eq_refl => eq_refl end)).

Definition funext_app {f g}
  : forall (hom : forall a, f a = g a), happly (funext hom) = hom
  := Adjointification.fg_id' happly funext funext_comp
     (fun hom => match funext_contract hom in (_ = existT _ g hom)
      return happly (funext hom) = hom
      with eq_refl => f_equal happly (funext_comp eq_refl) end).

Definition happly_adjoint {f g}
  : forall feq : f = g,
    funext_app (happly feq) = f_equal happly (funext_comp feq)
  := Adjointification.f_adjoint _ _ _ _.

Definition funext_adjoint {f g}
  : forall hom : forall a, f a = g a,
    funext_comp (funext hom) = f_equal funext (funext_app hom)
  := Adjointification.g_adjoint _ _ _ _.
End funext_app.


Require Import Metatheory.
Section MoreDom.

Variable X: Type.

Lemma map_fst_dom : forall (E:list (atom*X))
  (F:list (atom*X)) (H1: List.map fst E = List.map fst F),
  dom E [=] dom F.
Proof.
  induction E as [|[] ?]; destruct F as [|[] ?]; simpl;
    intros; inversion H1; subst.
    fsetdec.
    apply IHE in H2. fsetdec.
Qed.

Lemma uniq_map_fst : forall (E:list (atom*X))
  (H1: uniq E) (F:list (atom*X)) (H2: List.map fst E = List.map fst F),
  uniq F.
Proof.
  induction 1; destruct F as [|[] ?]; simpl; intros; auto.
    congruence.

    simpl_env.
    inversion H2; subst.
    constructor; auto.
      apply map_fst_dom in H4. fsetdec.
Qed.

Lemma in_dom_cons_inv : forall a (v:X) l id0,
  id0 `in` dom ((a,v)::l) ->
  id0 = a \/ id0 `in` dom l.
Proof.
  intros.
  simpl in H. fsetdec.
Qed.

Lemma in_dom_app_inv : forall id0 D1 D2,
  id0 `in` D1 `union` D2 ->
  id0 `in` D1 \/ id0 `in` D2.
Proof.
  intros.
  fsetdec.
Qed.

Lemma in_dom_ext_right : forall i0 D1 D2,
  i0 `in` D1 ->
  i0 `in` D1 `union` D2.
Proof. fsetdec. Qed.

Lemma in_dom_ext_left : forall i0 D1 D2,
  i0 `in` D1 ->
  i0 `in` D2 `union` D1.
Proof. fsetdec. Qed.

Lemma dom_rev_eq: forall (l0:list (atom*X)), dom l0 [=] dom (rev l0).
Proof.
  induction l0 as [|[]]; simpl.
    fsetdec.
    simpl_env. fsetdec.
Qed.

Lemma uniq_rev: forall (l0:list (atom*X)) (H:uniq l0), uniq (rev l0).
Proof.
  induction l0; simpl; intros; auto.
    inversion H. subst.
    simpl_env.
    apply uniq_app_4; auto.
    apply disjoint_sym_1.
    apply disjoint_one_2.
      rewrite <- dom_rev_eq. auto.
Qed.

Lemma In_InDom : forall id1 (v1:X) l1,
  In (id1, v1) l1 -> id1 `in` dom l1.
Proof.
  induction l1 as [|[id2 v2]]; simpl; intros.
    inversion H.

    destruct H as [H | H].
      inversion H. auto.
      auto.
Qed.

End MoreDom.

Section MoreAssocLists.

Variable X: Type.
Definition AssocList := list (atom*X).

(* update if exists, add it otherwise *)
Fixpoint updateAddAL (m:AssocList) (i:atom) (gv:X) : AssocList :=
match m with
| nil => (i, gv)::nil
| (i', gv')::m' =>
  if (eq_dec i i')
  then (i', gv)::m'
  else (i', gv')::updateAddAL m' i gv
end.

Definition updateAddALs (lc:AssocList) (kvs:list (atom*X)) :
  AssocList :=
fold_left  (fun lc0 kv => let '(k, v) := kv in updateAddAL lc0 k v) kvs lc.

Lemma simpl_cons_updateAddALs : forall lc v k vks,
  updateAddALs lc ((v,k)::vks) = updateAddALs (updateAddAL lc v k) vks.
Proof. auto. Qed.

(* update only if exists, do nothing otherwise *)
Fixpoint updateAL (m:AssocList) (i:atom) (gv:X) : AssocList :=
match m with
| nil => nil
| (i', gv')::m' =>
  if (eq_dec i i')
  then (i', gv)::m'
  else (i', gv')::updateAL m' i gv
end.

Fixpoint lookupAL (m:AssocList) (i:atom) : option X :=
match m with
| nil => None
| (i', gv')::m' =>
  if (eq_dec i i')
  then Some gv'
  else lookupAL m' i
end.

Fixpoint deleteAL (m:AssocList) (i:atom) : AssocList :=
match m with
| nil => nil
| (id0, gv0)::m' =>
    if (i == id0) then deleteAL m' i else (id0, gv0)::deleteAL m' i
end.

Definition rollbackAL (locals : AssocList) (i:atom) (lc0 : AssocList)
  : AssocList :=
match (lookupAL lc0 i) with
| Some gv0 => updateAL locals i gv0
| None => deleteAL locals i
end.

Lemma updateAddAL_mono : forall l1 id0 e0 id1,
  id1 `in` dom l1 ->
  id1 `in` dom (updateAddAL l1 id0 e0).
Proof.
  induction l1; intros; simpl in *.
    contradict H; fsetdec.

    destruct a.
    destruct (id0 == a); subst; simpl; auto.
      assert (id1 = a \/ id1 `in` dom l1) as J.
        fsetdec.
      destruct J as [J | J]; subst; auto.
Qed.

Lemma lookupAL_updateAL_in : forall m id0 gv0,
  id0 `in` dom m ->
  lookupAL (updateAL m id0 gv0) id0 = Some gv0.
Proof.
  induction m; intros; simpl.
    simpl in H. contradict H; auto.

    destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
      subst; simpl.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) a a);
        subst; simpl; auto.
        contradict n; auto.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
        subst; simpl; auto.
        contradict n; auto.

        assert (id0 = a \/ id0 `in` dom m) as J. simpl in H. fsetdec.
        destruct J as [J | J]; subst.
          contradict n; auto.
          apply IHm with (gv0:=gv0) in J; auto.
Qed.

Lemma lookupAL_updateAddAL_eq : forall m id0 gv0,
  lookupAL (updateAddAL m id0 gv0) id0 = Some gv0.
Proof.
  induction m; intros; simpl.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 id0); subst;
      simpl; auto.
      contradict n; auto.

    destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
      subst; simpl.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) a a);
        subst; simpl; auto.
        contradict n; auto.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
        subst; simpl; auto.
        contradict n; auto.
Qed.

Lemma notin_lookupAL_None : forall m id0,
  id0 `notin` dom m ->
  lookupAL m id0 = None.
Proof.
  induction m; intros; simpl; auto.
    destruct a.
    simpl in H.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
      subst; simpl; auto.
      contradict H; auto.
Qed.

Lemma lookupAL_updateAL_neq : forall m id0 id1 gv0,
  id1 <> id0 ->
  lookupAL m id1 = lookupAL (updateAL m id0 gv0) id1.
Proof.
  induction m; intros; simpl; auto.
    destruct a.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 id0);
        subst; simpl; auto.
        contradict H; auto.
        destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a);
          subst; simpl; auto.
          destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
            subst; simpl; auto.
            contradict H; auto.
            destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) a a);
              subst; simpl; auto.
              contradict n1; auto.
          destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
            subst; simpl; auto.
            destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a);
              subst; simpl; auto.
              contradict n; auto.
            destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a);
              subst; simpl; auto.
              contradict n0; auto.
Qed.

Lemma lookupAL_updateAddAL_neq : forall m id0 id1 gv0,
  id1 <> id0 ->
  lookupAL m id1 = lookupAL (updateAddAL m id0 gv0) id1.
Proof.
  induction m; intros; simpl; auto.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 id0);
      subst; auto.
      contradict H; auto.

    destruct a.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 id0);
        subst; simpl; auto.
        contradict H; auto.
        destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a);
          subst; simpl; auto.
          destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
            subst; simpl; auto.
            contradict H; auto.
            destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) a a);
              subst; simpl; auto.
              contradict n1; auto.
          destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
            subst; simpl; auto.
            destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a);
              subst; simpl; auto.
              contradict n; auto.
            destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a);
              subst; simpl; auto.
              contradict n0; auto.
Qed.

Lemma lookupAL_Some_indom : forall m id0 gv,
  lookupAL m id0 = Some gv ->
  id0 `in` dom m.
Proof.
  induction m; intros.
    simpl in H. inversion H.

    simpl in H. destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst;
      simpl; auto.
      apply IHm in H; auto.
Qed.

Lemma lookupAL_None_notindom : forall m id0,
  lookupAL m id0 = None ->
  id0 `notin` dom m.
Proof.
  induction m; intros.
    auto.

    simpl in H. destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst;
      simpl; auto.
      inversion H.
Qed.

Lemma lookupAL_updateAL_notin : forall m id1 id0 gv0,
  id0 `notin` dom m ->
  lookupAL (updateAL m id0 gv0) id1 = lookupAL m id1.
Proof.
  induction m; intros; simpl; auto.

    destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst;
      simpl.
      simpl in H. contradict H; auto.

      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a); subst;
        simpl; auto.
Qed.

Lemma lookupAL_deleteAL_eq : forall m id0,
  lookupAL (deleteAL m id0) id0 = None.
Proof.
  induction m; intros id0; simpl; auto.
  destruct a.
  destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
    subst; auto.

    simpl.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
      subst; auto.
      congruence.
Qed.

Lemma indom_lookupAL_Some : forall m id0,
  id0 `in` dom m ->
  exists gv0, lookupAL m id0 = Some gv0.
Proof.
  induction m; intros.
    simpl in H.
    contradict H; auto.

    destruct a.
    simpl in H.
    assert (id0 = a \/ id0 `in` dom m) as J.
      fsetdec.
    destruct J as [EQ | J]; subst.
      simpl.
      exists x.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) a a); auto.
        contradict n; auto.

      simpl.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst;
        auto.
        exists x. auto.
Qed.

Lemma updateAL_dom_eq : forall m id0 gv0,
  dom m [=] dom (updateAL m id0 gv0).
Proof.
  induction m; intros; simpl.
    fsetdec.

    destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst.
      simpl. fsetdec.
      simpl. rewrite <- IHm; auto. fsetdec.
Qed.

Lemma updateAL_uniq : forall m id0 gv0,
  uniq m ->
  uniq (updateAL m id0 gv0).
Proof.
  intros m id0 gv0 Uniq.
  induction Uniq; simpl; auto.
  destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 x); subst;
    auto.
    simpl_env.
    apply uniq_push; auto.
      rewrite <- updateAL_dom_eq; auto.
Qed.

Lemma lookupAL_deleteAL_neq : forall m id0 id1,
  id0 <> id1 ->
  lookupAL (deleteAL m id0) id1 = lookupAL m id1.
Proof.
  induction m; intros id0 id1 id0_isnt_id1; simpl; auto.
  destruct a.
  destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a); subst;
      auto.
      contradict id0_isnt_id1; auto.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a); subst;
      simpl.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) a a); subst;
        auto.
        contradict n0; auto.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id1 a); subst;
        auto.
        contradict n0; auto.
Qed.

Lemma deleteAL_dom_sub : forall m id0,
  dom (deleteAL m id0) [<=] dom m.
Proof.
  induction m; intros; simpl.
    fsetdec.

    destruct a.
    assert (J:=@IHm id0).
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); simpl;
      subst; fsetdec.
Qed.

Lemma deleteAL_uniq : forall m id0,
  uniq m ->
  uniq (deleteAL m id0).
Proof.
  intros m id0 Uniq.
  induction Uniq; simpl; auto.
  destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 x); subst;
    auto.
    simpl_env.
    assert (J:=@deleteAL_dom_sub E id0).
    apply uniq_push; auto.
Qed.

Lemma updateAddAL_dom_eq : forall sm id0 st0,
  dom (updateAddAL sm id0 st0) [=] dom sm `union` {{id0}}.
Proof.
  induction sm; intros; simpl; try solve [fsetdec].
    destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); simpl;
      try solve [fsetdec].
      assert (J:=@IHsm id0 st0). fsetdec.
Qed.

Lemma updateAddAL_uniq : forall sm id0 st0,
  uniq sm ->
  uniq (updateAddAL sm id0 st0).
Proof.
  induction sm; intros; simpl; auto.
    destruct a.

    destruct_uniq.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst;
      try solve [solve_uniq].
      apply IHsm with (id0:=id0)(st0:=st0) in H.
      assert (J:=@updateAddAL_dom_eq sm id0 st0).
      solve_uniq.
Qed.

Lemma updateAddAL_inversion : forall sm id0 st0 id1 st1,
  uniq sm ->
  binds id1 st1 (updateAddAL sm id0 st0) ->
  (id0 <> id1 /\ binds id1 st1 sm) \/ (id0 = id1 /\ st0 = st1).
Proof.
  induction sm; intros id0 st0 id1 st1 Uniq Binds; simpl in Binds.
    analyze_binds Binds.

    destruct a.
    inversion Uniq; subst.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst.
      analyze_binds Binds.
      left. split; auto.
        apply binds_In in BindsTac.
        fsetdec.

      analyze_binds Binds.
      apply IHsm in BindsTac; auto.
        destruct BindsTac; auto.
          destruct H; auto.
Qed.

Lemma updateAddAL_in_inversion : forall sm id0 st0 id1,
  uniq sm ->
  id1 `in` dom (updateAddAL sm id0 st0) ->
  (id0 <> id1 /\ id1 `in` dom sm) \/ (id0 = id1).
Proof.
  induction sm; intros id0 st0 id1 Uniq Hin; simpl in Hin.
    right. fsetdec.

    destruct a.
    inversion Uniq; subst.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst.
      destruct (@in_dom_cons_inv _ _ _ _ _ Hin) as [EQ | id1_in_sm]; subst; auto.
        left. split; fsetdec.

      destruct (@in_dom_cons_inv _ _ _ _ _ Hin) as [EQ | id1_in_sm]; subst; simpl; auto.
        apply IHsm in id1_in_sm; auto.
        destruct id1_in_sm as [[id0_isnt_id1 id1_in_sm] | EQ]; auto.
Qed.

Lemma binds_updateAddAL_eq : forall sm id0 st0,
  binds id0 st0 (updateAddAL sm id0 st0).
Proof.
  induction sm; intros id0 st0; simpl; auto.
    destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst; auto.
Qed.

Lemma binds_updateAddAL_neq : forall sm id0 st0 id1 st1,
  binds id1 st1 sm ->
  id0 <> id1 ->
  binds id1 st1 (updateAddAL sm id0 st0).
Proof.
  induction sm; intros id0 st0 id1 st1 Hbinds id0_neq_id1; simpl; auto.
    destruct a.
    simpl_env in Hbinds.
    analyze_binds Hbinds.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst; auto.
        contradict id0_neq_id1; auto.

      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst; auto.
Qed.

Lemma in_updateAddAL_eq : forall sm id0 st0,
  id0 `in` dom (updateAddAL sm id0 st0).
Proof.
  induction sm; intros id0 st0; simpl; auto.
    destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst; simpl; auto.
Qed.

Lemma in_updateAddAL_neq : forall sm id0 st0 id1,
  id1 `in` dom sm ->
  id0 <> id1 ->
  id1 `in` dom (updateAddAL sm id0 st0).
Proof.
  induction sm; intros id0 st0 id1 Hbinds id0_neq_id1; simpl; auto.
    destruct a.
    apply in_dom_cons_inv in Hbinds.
    destruct Hbinds; subst.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst; simpl; auto.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a); subst; simpl; auto.
Qed.

Lemma mergeALs_inv : forall l2b l2b' B l0,
  uniq (l2b++l2b') ->
  lookupAL (l2b++l2b') l0 = Some B ->
  lookupAL l2b l0 = Some B \/
  lookupAL l2b' l0 = Some B.
Proof.
  intros.
  induction l2b; auto.
    destruct a. simpl in *.
    inversion H; subst.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) l0 a); subst; auto.
Qed.

Lemma mergeALs_app : forall l2b l2b' B l0,
  uniq (l2b++l2b') ->
  lookupAL l2b l0 = Some B \/ lookupAL l2b' l0 = Some B ->
  lookupAL (l2b++l2b') l0 = Some B.
Proof.
  intros.
  induction l2b; auto.
    destruct H0 as [H0 | H0]; simpl_env; auto.
    inversion H0.

    destruct a. simpl in H.
    inversion H; subst. clear H.
    destruct H0 as [H0 | H0]; simpl in *.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) l0 a);
        subst; auto.
      destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) l0 a);
        subst; auto.
        apply lookupAL_Some_indom in H0.
        contradict H0; auto.
Qed.

Lemma lookupAL_updateAL_Some_eq : forall lc id0 gv0 gv1,
  lookupAL lc id0 = Some gv0 ->
  lookupAL (updateAL lc id0 gv1) id0 = Some gv1.
Proof.
  intros lc id0 gv0 gv1 Hl.
  destruct (AtomSetProperties.In_dec id0 (dom lc)).
    rewrite lookupAL_updateAL_in; auto.

    rewrite notin_lookupAL_None in Hl; auto.
    inversion Hl.
Qed.

Lemma lookupAL_updateAL_None_eq : forall lc id0 gv1,
  lookupAL lc id0 = None ->
  lookupAL (updateAL lc id0 gv1) id0 = None.
Proof.
  intros lc id0 gv1 Hl.
  destruct (AtomSetProperties.In_dec id0 (dom lc)).
    apply indom_lookupAL_Some in i.
    destruct i as [gv0 i].
    rewrite i in Hl.
    inversion Hl.

    rewrite lookupAL_updateAL_notin; auto.
Qed.

Lemma lookupAL_updateAL_ident: forall id0 gv0 lc ,
  lookupAL lc id0 = Some gv0 ->
  updateAL lc id0 gv0 = lc.
Proof.
  induction lc; simpl; intros; auto.
    destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
      subst; auto.
      inversion H. subst. auto.

      rewrite IHlc; auto.
Qed.

Lemma lookupAL_updateAddAL_ident: forall id0 gv0 lc ,
  lookupAL lc id0 = Some gv0 ->
  updateAddAL lc id0 gv0 = lc.
Proof.
  induction lc; simpl; intros; auto.
    congruence.

    destruct a.
    destruct (@eq_dec atom (@EqDec_eq_of_EqDec atom EqDec_atom) id0 a);
      subst; auto.
      inversion H. subst. auto.

      rewrite IHlc; auto.
Qed.

Lemma lookupAL_rollbackAL_neq : forall lc id0 lc0 id1,
  id0 <> id1 ->
  lookupAL lc id1 = lookupAL (rollbackAL lc id0 lc0) id1.
Proof.
  intros lc id0 lc0 id1 id0_isnt_id1.
  unfold rollbackAL.
  destruct (lookupAL lc0 id0).
    eapply lookupAL_updateAL_neq; eauto.
    rewrite lookupAL_deleteAL_neq; auto.
Qed.

Lemma lookupAL_rollbackAL_Some_eq : forall lc id0 lc0 gv0,
  lookupAL lc id0 = Some gv0 ->
  lookupAL (rollbackAL lc id0 lc0) id0 = lookupAL lc0 id0.
Proof.
  intros lc id0 lc0 gv0 HlookupAL.
  unfold rollbackAL.
  remember (lookupAL lc0 id0) as ogv0.
  destruct ogv0.
    rewrite Heqogv0.
    erewrite lookupAL_updateAL_Some_eq with (gv0:=gv0); eauto.

    rewrite lookupAL_deleteAL_eq; auto.
Qed.

Lemma lookupAL_rollbackAL_None_eq : forall lc id0 lc0,
  lookupAL lc id0 = None ->
  lookupAL (rollbackAL lc id0 lc0) id0 = None.
Proof.
  intros lc id0 lc0 HlookupAL.
  unfold rollbackAL.
  destruct (lookupAL lc0 id0).
    erewrite lookupAL_updateAL_None_eq; eauto.
    erewrite lookupAL_deleteAL_eq; eauto.
Qed.

Lemma rollbackAL_uniq : forall id0 lc0 lc,
  uniq lc ->
  uniq (rollbackAL lc id0 lc0).
Proof.
  intros id0 lc0 lc Huniqc.
  unfold rollbackAL.
  destruct (lookupAL lc0 id0).
    apply updateAL_uniq; auto.
    apply deleteAL_uniq; auto.
Qed.

Lemma lookupAL_rollbackAL_eq : forall lc id0 lc0 gv,
  lookupAL lc id0 = Some gv ->
  lookupAL (rollbackAL lc id0 lc0) id0 = lookupAL lc0 id0.
Proof.
  intros lc id0 lc0 gv HlookupAL.
  unfold rollbackAL.
  remember (lookupAL lc0 id0) as ogv0.
  destruct ogv0.
    apply lookupAL_Some_indom in HlookupAL.
    rewrite lookupAL_updateAL_in; auto.

    rewrite lookupAL_deleteAL_eq; auto.
Qed.

Definition eqAL lc1 lc2 :=
  forall i, lookupAL lc1 i = lookupAL lc2 i.

Lemma eqAL_refl : forall lc,
  eqAL lc lc.
Proof. unfold eqAL. auto. Qed.

Lemma eqAL_sym : forall lc1 lc2,
  eqAL lc1 lc2 ->
  eqAL lc2 lc1.
Proof. unfold eqAL. auto. Qed.

Lemma eqAL_trans : forall lc1 lc2 lc3,
  eqAL lc1 lc2 ->
  eqAL lc2 lc3 ->
  eqAL lc1 lc3.
Proof.
  unfold eqAL.
  intros.
  assert (J1:=@H i).
  assert (J2:=@H0 i).
  rewrite J1. auto.
Qed.

Lemma eqAL_indom_iff : forall lc1 lc1' id0,
  eqAL lc1 lc1' ->
  (id0 `in` dom lc1 <-> id0 `in` dom lc1').
Proof.
  intros lc1 lc1' id0 HeqAL.
  split; intro J.
    assert (J':=@HeqAL id0).
    apply indom_lookupAL_Some in J; auto.
    destruct J as [gv0 J].
    rewrite J' in J.
    apply lookupAL_Some_indom in J; auto.

    assert (J':=@HeqAL id0).
    apply indom_lookupAL_Some in J; auto.
    destruct J as [gv0 J].
    rewrite J in J'.
    apply lookupAL_Some_indom in J'; auto.
Qed.

Lemma eqAL_indom_onlyif : forall lc1 lc1' id0,
  eqAL lc1 lc1' ->
  id0 `in` dom lc1 ->
  id0 `in` dom lc1'.
Proof.
  intros.
  apply eqAL_indom_iff with (id0:=id0) in H.
  destruct H; auto.
Qed.

Lemma eqAL_indom_if : forall lc1 lc1' id0,
  eqAL lc1 lc1' ->
  id0 `in` dom lc1' ->
  id0 `in` dom lc1.
Proof.
  intros.
  apply eqAL_indom_iff with (id0:=id0) in H.
  destruct H; auto.
Qed.

Lemma eqAL_notindom_iff : forall lc1 lc1' id0,
  eqAL lc1 lc1' ->
  (id0 `notin` dom lc1 <-> id0 `notin` dom lc1').
Proof.
  intros.
  split; intro J.
    apply notin_lookupAL_None in J.
    rewrite H in J.
    apply lookupAL_None_notindom in J; auto.

    apply notin_lookupAL_None in J.
    rewrite <- H in J.
    apply lookupAL_None_notindom in J; auto.
Qed.

Lemma eqAL_notindom_onlyif : forall lc1 lc1' id0,
  eqAL lc1 lc1' ->
  id0 `notin` dom lc1 ->
  id0 `notin` dom lc1'.
Proof.
  intros.
  apply eqAL_notindom_iff with (id0:=id0) in H.
  destruct H; auto.
Qed.

Lemma eqAL_notindom_if : forall lc1 lc1' id0,
  eqAL lc1 lc1' ->
  id0 `notin` dom lc1' ->
  id0 `notin` dom lc1.
Proof.
  intros.
  apply eqAL_notindom_iff with (id0:=id0) in H.
  destruct H; auto.
Qed.

Lemma eqAL_updateAL : forall lc1 lc2 id0 gv0,
  eqAL lc1 lc2 ->
  eqAL (updateAL lc1 id0 gv0) (updateAL lc2 id0 gv0).
Proof.
  unfold eqAL.
  intros.
  assert (J:=H i) .
  destruct (id0==i); subst.
    destruct (@AtomSetProperties.In_dec i (dom lc1))
      as [id0_in_lc1 | id0_notin_lc1].
      rewrite lookupAL_updateAL_in; auto.
      rewrite lookupAL_updateAL_in; auto.
      eapply eqAL_indom_onlyif; eauto.

      rewrite lookupAL_updateAL_notin; auto.
      rewrite lookupAL_updateAL_notin; auto.
      eapply eqAL_notindom_onlyif; eauto.

    rewrite <- lookupAL_updateAL_neq; auto.
    rewrite <- lookupAL_updateAL_neq; auto.
Qed.

Lemma eqAL_updateAddAL : forall lc1 lc2 id0 gv0,
  eqAL lc1 lc2 ->
  eqAL (updateAddAL lc1 id0 gv0) (updateAddAL lc2 id0 gv0).
Proof.
  unfold eqAL.
  intros.
  assert (J:=H i) .
  destruct (id0==i); subst.
    rewrite lookupAL_updateAddAL_eq; auto.
    rewrite lookupAL_updateAddAL_eq; auto.

    erewrite <- lookupAL_updateAddAL_neq; eauto.
    erewrite <- lookupAL_updateAddAL_neq; eauto.
Qed.

Lemma lookupAL_trunc_head : forall i0 l2 l1,
  i0 `notin` dom l1 ->
  lookupAL (l1++l2) i0 = lookupAL l2 i0.
Proof.
  induction l1 as [|[]]; simpl; intros; auto.
    destruct (i0 == a); subst.
      fsetdec.
      apply IHl1. fsetdec.
Qed.

Lemma lookupAL_trunc_tail : forall i0 l2 l1,
  i0 `notin` dom l2 ->
  lookupAL (l1++l2) i0 = lookupAL l1 i0.
Proof.
  induction l1 as [|[]]; simpl; intros.
    apply notin_lookupAL_None; auto.

    destruct (i0 == a); subst; auto.
Qed.

Lemma lookupAL_rev_eq : forall i0 l0 (Huniq: uniq l0),
  lookupAL l0 i0 = lookupAL (rev l0) i0.
Proof.
  intros.
  induction Huniq; auto.
    simpl.
    destruct (i0 == x); subst; simpl_env.
      rewrite dom_rev_eq in H.
      rewrite lookupAL_trunc_head; simpl; auto.
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) x x);
        try congruence.

      rewrite lookupAL_trunc_tail; simpl; auto.
Qed.

Lemma lookupAL_weaken : forall i0 nm1 r nm2
  (Hlkup: lookupAL nm1 i0 = Some r),
  uniq (nm2 ++ nm1) ->
  lookupAL (nm2 ++ nm1) i0 = Some r.
Proof.
  induction nm2 as [|[]]; simpl; intros; auto.
    destruct (i0 == a); subst.
      inversion H. subst.
      apply lookupAL_Some_indom in Hlkup.
      contradict H4. simpl_env. fsetdec.

      inversion H. subst.
      apply IHnm2; auto.
Qed.

Lemma lookupAL_middle_inv: forall i0 a l0,
  lookupAL l0 i0 = Some a ->
  exists l1, exists l2, l0 = l1 ++ (i0,a) :: l2.
Proof.
  induction l0 as [|[i' gv']]; simpl; intros.
    congruence.

    destruct (i0 == i'); subst.
      inversion H; subst. exists nil. exists l0. auto.

      apply IHl0 in H.
      destruct H as [l1 [l2 H]]; subst.
      exists ((i', gv')::l1). exists l2. auto.
Qed.

Lemma lookupAL_middle_inv': forall l0 i0,
  lookupAL l0 i0 <> None ->
  exists a, exists l1 : list (atom * X), exists l2 : list (atom * X),
    l0 = l1 ++ (i0, a) :: l2.
Proof.
  intros.
  remember (lookupAL l0 i0) as R.
  destruct R; try congruence.
  symmetry in HeqR. exists x.
  apply lookupAL_middle_inv in HeqR; auto.
Qed.

Lemma In_lookupAL : forall id1 v1 l1,
  uniq l1 -> In (id1, v1) l1 -> lookupAL l1 id1 = Some v1.
Proof.
  induction l1 as [|[id2 v2]]; simpl; intros.
    match goal with | H: False |- _ => inversion H end.

    destruct_uniq.
    destruct H0 as [H0 | H0].
      inversion H0.
      destruct (id1 == id1); try congruence; auto.

      destruct (id1 == id2); subst; auto.
      apply In_InDom in H0. contradict H0; auto.
Qed.

Lemma lookupAL_in : forall id1 v1 l1 (Hlkup: lookupAL l1 id1 = Some v1),
  In (id1, v1) l1.
Proof.
  intros.
  apply lookupAL_middle_inv in Hlkup.
  destruct Hlkup as [l2 [l3 EQ]]; subst.
  apply in_or_app. simpl; auto.
Qed.

End MoreAssocLists.


From Coq Require Import Morphisms.

From ITree.Extra Require Import Secure.Labels.

Class Lattice := {
  T : Type;
  join : T -> T -> T;
  meet : T -> T -> T;
  eqlat : T -> T -> Prop;
  top : T;
  bot : T;

}.

Class LatticeLaws (Lat : Lattice) := {
  eq_equiv : Equivalence eqlat;
  join_proper : Proper (eqlat ==> eqlat ==> eqlat) join;
  meet_proper : Proper (eqlat ==> eqlat ==> eqlat) meet;
  eqlat_dec : forall l1 l2, {eqlat l1 l2} + {~ eqlat l1 l2};
  join_comm : forall l1 l2, eqlat (join l1 l2) (join l2 l1);
  join_assoc : forall l1 l2 l3, eqlat (join l1 (join l2 l3)) (join (join l1 l2) l3 );
  meet_comm : forall l1 l2, eqlat (meet l1 l2) (meet l2 l1);
  meet_assoc : forall l1 l2 l3, eqlat (meet l1 (meet l2 l3) ) (meet (meet l1 l2) l3 );
  join_unit : forall l, eqlat l (join l bot);
  meet_unit : forall l, eqlat l (meet l top);
  absorb1 : forall l1 l2, eqlat (join l1 (meet l1 l2) ) l1;
  absorb2 : forall l1 l2, eqlat (meet l1 (join l1 l2) ) l1;
}.

#[global] Instance PreOrderOfLattice (Lat : Lattice)  : Preorder :=
  {|
  L := T;
  leq := fun l1 l2 => eqlat (join l1 l2) l2;
  |}.

Lemma join_idempot (Lat : Lattice) {HLat : LatticeLaws Lat} (l : L) :
  eqlat (join l l) l.
Proof.
  destruct HLat. setoid_rewrite meet_unit0 at 3. apply absorb3.
Qed.

Lemma meet_idempot (Lat : Lattice) {HLat : LatticeLaws Lat} (l : L) :
  eqlat (meet l l) l.
Proof.
  destruct HLat. setoid_rewrite join_unit0 at 3. apply absorb4.
Qed.

Lemma leq_trans_lat (Lat : Lattice) {HLat : LatticeLaws Lat}  (l1 l2 l3 : L) :
  leq l1 l2 -> leq l2 l3 -> leq l1 l3.
Proof.
  cbn. intros H12 H23. destruct HLat. setoid_rewrite <- H23.
  rewrite join_assoc0. rewrite H12. reflexivity.
Qed.

Lemma leq_join_l (Lat : Lattice) {HLat : LatticeLaws Lat}  (l1 l2 : L) :
  leq l1 (join l1 l2).
Proof.
  cbn. assert (LatticeLaws Lat). auto. destruct HLat. rewrite join_assoc0. rewrite join_idempot; auto.
  reflexivity.
Qed.

Lemma leq_join_r (Lat : Lattice) {HLat : LatticeLaws Lat}  (l1 l2 : L) :
  leq l2 (join l1 l2).
Proof.
  cbn. assert (LatticeLaws Lat). auto. destruct HLat. rewrite join_comm0. rewrite <- join_assoc0.
  rewrite join_idempot; auto. reflexivity.
Qed.

Lemma leq_refl_lat (Lat : Lattice) {HLat : LatticeLaws Lat} l :
  leq l l.
Proof.
  cbn. apply join_idempot; auto.
Qed.

Lemma leq_join_and (Lat : Lattice) {HLat : LatticeLaws Lat} (l1 l2 l3 : L) :
  leq (join l1 l2) l3 -> leq l1 l3 /\ leq l2 l3.
Proof.
  intros. split.
  eapply leq_trans_lat; eauto. apply leq_join_l; auto.
  eapply leq_trans_lat; eauto. apply leq_join_r; auto.
Qed.

Lemma leqlat_join_or (Lat : Lattice) {HLat : LatticeLaws Lat} (l1 l2 l3 : L) :
  ~ (leq (join l1 l2) l3) -> ~ leq l1 l3 \/ ~ leq l2 l3.
Proof.
  intros. cbn. destruct HLat. destruct (eqlat_dec0 (join l1 l3) l3); eauto.
  right. intro. cbn in H. rewrite <- join_assoc0 in H.
  rewrite H0 in H. contradiction.
Qed.

Lemma leq_dec (Lat : Lattice) {HLat : LatticeLaws Lat} (l1 l2 : L) :
  {leq l1 l2} + {~ leq l1 l2}.
Proof.
  cbn. destruct HLat. auto.
Qed.

Lemma leq_bot (Lat : Lattice) {HLat : LatticeLaws Lat} l :
  leq bot l.
Proof.
  cbn. destruct HLat. rewrite join_comm0. rewrite <- join_unit0.
  reflexivity.
Qed.

Lemma leq_top  (Lat : Lattice) {HLat : LatticeLaws Lat} l :
  leq l top.
Proof.
  cbn. destruct HLat. rewrite join_comm0. rewrite (meet_unit0 l).
  rewrite meet_comm0. rewrite absorb3. reflexivity.
Qed.

Lemma leq_join_lub (Lat : Lattice) {HLat : LatticeLaws Lat} l1 l2 l3 :
  leq l1 l3 -> leq l2 l3 -> leq (join l1 l2) l3.
Proof.
  cbn. intros. destruct HLat. rewrite <- join_assoc0. rewrite H0. auto.
Qed.

#[global] Instance proper_leq1 (Lat : Lattice) {HLat : LatticeLaws Lat} : Proper (eqlat ==> eqlat ==> Basics.flip Basics.impl) leq.
Proof.
  cbn. repeat intro. destruct HLat. rewrite H, H0. auto.
Qed.

#[global] Instance proper_leq2 (Lat : Lattice) {HLat : LatticeLaws Lat} : Proper (eqlat ==> eqlat ==> Basics.impl) leq.
Proof.
  cbn. repeat intro. destruct HLat. rewrite <- H. rewrite <- H0. auto.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* Elementary Diophantine constraints w/o parameters
    and with only the constant 1 i.e. constraints
    are of three shapes:

      x = 1 | x+y = z | x*y = z  with x,y,z in nat

  *)

Require Import List Arith.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_decidable utils_nat.

From Undecidability.DiophantineConstraints
  Require Import H10C.

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Notation "〚 c 〛" := (h10c_sem c).
Local Notation " '⟪' c '⟫' " := (fun φ => h10uc_sem φ c).

Section decidability_of_validity.

  (* Validity is decidable, this is easily proved in here
      but of course satisfiability is undecidable but this
      is much more complicated to establish *)

  Let plus_swap (P Q : Prop) : { P } + { Q } -> { Q } + { P }.
  Proof. tauto. Qed.

  Fact h10c_sem_dec c φ : {〚c〛φ } + { ~〚c〛φ }.
  Proof. destruct c; apply eq_nat_dec. Qed.

  Fact h10lc_sem_dec l φ : { c | In c l /\ ~〚c〛φ } + { forall c, In c l ->〚c〛φ }.
  Proof.
    apply list_choose_dep.
    intros c _; apply plus_swap, h10c_sem_dec.
  Qed.

  Fact h10luc_sem_dec l φ : { c | In c l /\ ~ ⟪c⟫ φ } + { forall c, In c l -> ⟪c⟫ φ }.
  Proof.
    apply list_choose_dep.
    intros c _; apply plus_swap.
    destruct c as ((?,?),?); apply eq_nat_dec.
  Qed.

End decidability_of_validity.

Section h10c_vars_bound.

  (* A small utility library that help at encoding φ with a finitary map *)

  Definition h10c_vars c :=
    match c with
      | h10c_one x      => x::nil
      | h10c_plus x y z => x::y::z::nil
      | h10c_mult x y z => x::y::z::nil
    end.

  Definition h10uc_vars (c : h10uc) :=
    match c with (x,y,z) => x::y::z::nil end.

  Fact h10c_vars_equiv c phi psy : (forall x, In x (h10c_vars c) -> phi x = psy x)
                                -> 〚c〛phi <->〚c〛psy.
  Proof.
    destruct c; simpl; intros H; repeat rewrite H; tauto.
  Qed.

  Fact h10uc_vars_equiv c phi psy : (forall x, In x (h10uc_vars c) -> phi x = psy x)
                                -> ⟪c⟫ phi <-> ⟪c⟫ psy.
  Proof.
    destruct c as ((?,?),?); simpl; intros H; repeat rewrite H; tauto.
  Qed.

  Definition h10lc_vars := flat_map h10c_vars.
  Definition h10luc_vars := flat_map h10uc_vars.

  Fact h10lc_vars_equiv l phi psy : (forall x, In x (h10lc_vars l) -> phi x = psy x)
                                  -> forall c, In c l ->〚c〛phi <->〚c〛psy.
  Proof.
    intros H c Hc.
    apply h10c_vars_equiv.
    intros x Hx; apply H, in_flat_map.
    exists c; auto.
  Qed.

  Fact h10luc_vars_equiv l phi psy : (forall x, In x (h10luc_vars l) -> phi x = psy x)
                                   -> forall c, In c l -> ⟪c⟫ phi <-> ⟪c⟫ psy.
  Proof.
    intros H c Hc.
    apply h10uc_vars_equiv.
    intros x Hx; apply H, in_flat_map.
    exists c; auto.
  Qed.

  Definition h10lc_bound l := S (lmax (h10lc_vars l)).
  Definition h10luc_bound l := S (lmax (h10luc_vars l)).

  Fact h10lc_bound_prop l phi psy : (forall x, x < h10lc_bound l -> phi x = psy x)
                                  -> forall c, In c l ->〚c〛phi <->〚c〛psy.
  Proof.
    intros H; apply h10lc_vars_equiv.
    intros x Hc; apply H, le_n_S, lmax_prop; auto.
  Qed.

  Fact h10luc_bound_prop l phi psy : (forall x, x < h10luc_bound l -> phi x = psy x)
                                   -> forall c, In c l -> ⟪c⟫ phi <-> ⟪c⟫ psy.
  Proof.
    intros H; apply h10luc_vars_equiv.
    intros x Hc; apply H, le_n_S, lmax_prop; auto.
  Qed.

End h10c_vars_bound.


Require Export Perm Sort.
Require Export Lia.

Definition FILL_IN_HERE {T: Type} : T.  Admitted.

(* [hexploit]: A very useful tactic, developed by Gil Hur.

   Suppose we have:

     H: P1 -> ... -> Pn -> Q
     ========================
     G

   [hexploit H] turns this goal into the following (n+1) subgoals:

     H: P1 -> ... -> Pn -> Q
     =========================
     P1

     ...

     H: P1 -> ... -> Pn -> Q
     =========================
     Pn

     H: P1 -> ... -> Pn -> Q
     =========================
     Q -> G
*)

Lemma __mp__: forall P Q: Type, P -> (P -> Q) -> Q.
Proof. intuition. Defined.

Ltac hexploit H := eapply __mp__; [eapply H|].

Example hexploit_example: forall (P Q: Prop) n
    (ASM: P /\ Q)
    (IMP: P -> Q -> n >= 5),
  n > 2.
Proof.
  intros.
  hexploit IMP.
  { destruct ASM; eauto. }
  { destruct ASM; eauto. }
  intros. nia.
Qed.

(***
    Definitions
 ***)

Fixpoint split (k: nat) (l: list nat) : list nat * list nat :=
  match k with
  | 0 => (nil, l)
  | S k' =>
    match l with
    | nil => (nil, l)
    | a::l' =>
      match split k' l' with
      | (l1,l2) => (a::l1, l2)
      end
    end
  end.

Compute split 3 [1;2;3;4;5].

Fixpoint merge' (fuel: nat) (l1 l2: list nat) : list nat :=
  match fuel with
  | 0 => nil
  | S fuel' =>
    match l1,l2 with
    | [],_ => l2
    | _,[] => l1
    | a::l1',b::l2' =>
      if a <=? b
      then a::merge' fuel' l1' l2
      else b::merge' fuel' l1 l2'
    end
  end.

Definition merge l1 l2 := merge' (length l1 + length l2) l1 l2.

Compute merge [1; 4] [3; 5].
Compute merge [2] [].

Fixpoint merge_sort' (fuel: nat) (l: list nat) : list nat :=
  match fuel with
  | 0 => l
  | S fuel' =>
    match l with
    | [] | [_] => l
    | _ =>
      match split (Nat.div2 (length l)) l with
      | (l1,l2) => merge (merge_sort' fuel' l1) (merge_sort' fuel' l2)
      end
    end
  end.

Definition merge_sort l := merge_sort' (length l) l.

Compute merge_sort [10;3;7;2;3;5;8].
Compute merge_sort [2;1].

Hint Constructors Permutation sorted.

(***
    Proofs
 ***)


Require Export D.

(** **** Problem #9 : 1 star (snd_fst_is_swap) *)
Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros. destruct p. simpl. reflexivity.
Qed.


(* week-03_the_exists_tactic.v *)
(* FPP 2020 - YSC3236 2020-2021, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 30 Aug 2020 *)

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

(* Paraphernalia: *)

Require Import Arith.

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

Lemma proving_an_existential_example_0 :
  exists n : nat,
    n = 0.
Proof.
  exists 0.
  reflexivity.
Qed.

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

Lemma proving_an_existential_example_1 :
  exists f : nat -> nat,
    forall n : nat,
      f n = n + 1.
Proof.
  exists S.
  intro n.
  Search (_ = _ + S _).
  Check (plus_n_Sm n 0).
  rewrite <- (plus_n_Sm n 0).
  Check Nat.add_0_r.
  rewrite -> (Nat.add_0_r n).
  reflexivity.
Qed.

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

(* end of week-03_the_exists_tactic.v *)


(** Podpora za algoritme za urejanje. *)

(** Delali bomo s seznami celih števil, pri čemer bomo uporabljali
    cela števila iz knjižnice [ZArith]. To so binarna cela števila,
    s katerimi lahko "učinkovito" računamo. *)

Require Import List.
Require Import Bool.
Require Import ZArith.

(** Aktiviramo notacijo za sezname. *)
Local Open Scope list_scope.

(** Najprej je treba definirati pojma "seznam je urejen" in
    "seznam [l1] je permutacija seznama [l2]".

    Izkaže se, da je "permutacija" tehnično precej zahtevna.
    Omejili se bomo na "seznama [l1] in [l2] imata enake elemente".
    Seznama [1;1;2] in [1;2;2] imata enake elemente in sta
    enako dolga, a nista permutacija drug drugega.
*)

(** Seznam je urejen, če je prazen, ima en element, ali je
    oblike [x :: y :: _], kjer je [x <= y] in je rep
    [y :: _] urejen.

    Uporabili bomo vzorec [(y :: _) as l'], ki pomeni "seznam
    [l'] oblike [y :: _]". S tem hkrati dobimo prvi element
    seznama [y] in celoten seznam [l'].
*)
Fixpoint urejen (l : list Z) :=
  match l with
    | nil => True
    | _ :: nil => True
    | x :: ((y :: _) as l') => (x <= y)%Z /\ urejen l'
  end.

(** Relacija [In x l] pomeni, da je [x] element seznama [l]. *)

Fixpoint vsebuje (l1 l2 : list Z) :=
  match l1 with
    | nil => True
    | x :: l => In x l2 /\ vsebuje l l2
  end.

Lemma vsebuje_In (x : Z) (l1 l2 : list Z) :
  In x l1 -> vsebuje l1 l2 -> In x l2.
Proof.
  admit. (* To bo naredil Jernej. *)
Qed.

(** Seznama [l1] in [l2] imata enake elemente, če sta
    vsebovana drug v drugem. *)
Definition enak (l1 l2 : list Z) :=
  vsebuje l1 l2 /\ vsebuje l2 l1.

(** Osnovne leme o vsebovanosti. *)

Lemma vsebuje_cons (x : Z) (l1 l2 : list Z) :
  vsebuje l1 l2 -> vsebuje l1 (x :: l2).
Proof.
  admit. (* To bo naredil Stepišnik. *)
Qed.

Lemma vsebuje_refl (l : list Z) : vsebuje l l.
Proof.
  induction l.
  - simpl ; auto.
  - simpl.
    split ; auto.
    now apply vsebuje_cons.
Qed.

Lemma vsebuje_trans (l1 l2 l3 : list Z) :
  vsebuje l1 l2 -> vsebuje l2 l3 -> vsebuje l1 l3.
Proof.
  admit. (* To bo naredila Eva. *)
Qed.

(** Vsak seznam je enak sam sebi. *)
Lemma enak_refl (l : list Z) : enak l l.
Proof.
  split ; apply vsebuje_refl.
Qed.

(** Če staknemo enake sezname, dobimo enaka seznama. *)
Lemma vsebuje_app (l1 l1' l2 l2' : list Z) :
  vsebuje l1 l1' -> vsebuje l2 l2' -> vsebuje (l1 ++ l2) (l1' ++ l2').
Proof.
  admit. (* To bo naredil Janoš. *)
Qed.

Lemma enak_app (l1 l1' l2 l2' : list Z) :
  enak l1 l1' -> enak l2 l2' -> enak (l1 ++ l2) (l1' ++ l2').
Proof.
  intros [H1 G1] [H2 G2].
  split ; now apply vsebuje_app.
Qed.

(** Če enakima seznamoma dodamo element na začetku, dobimo
    enaka seznama. *)
Lemma enak_cons (x : Z) (l1 l2 : list Z) :
  enak l1 l2 -> enak (x :: l1) (x :: l2).
Proof.
  intros [H1 H2].
  split ; simpl ; auto using vsebuje_cons.
Qed.

(** Potrebovali bomo tudi operacije, ki sezname razdelijo na dva
    podseznama. Na primer, v urejanju z zlivanjem seznam razdelimo
    takole: *)
Fixpoint razpolovi (l : list Z) :=
  match l with
    | nil => (nil, nil)
    | x :: nil => (nil, x :: nil)
    | x :: y :: l' =>
      let (l1, l2) := razpolovi l' in
        (x :: l1, y :: l2)
  end.

Eval compute in (razpolovi (1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil)%Z).

(** To je pomožna oblika indukcije na seznamih. Pravi, pa tole:
    denimo, da lastnost P in da

    - nil ima lastnost P
    - seznam z enim elementom (x :: nil) ima lastnost P, za vsak x
    - če ima seznam l lastnost P, potem ima tudi x :: y :: l lastnost P, za vse x, y, l

    Tedaj ima vsak seznam lasnost P.

    To inačico indukcije najlažje dokažemo tako, da napišemo ustrezno
    rekurzivno funkcijo, ki je po Curry-Howardu njen dokaz.
*)
Fixpoint list_ind_2
         {A : Set}
         (P : list A -> Prop)
         (p0 : P nil)
         (p1 : forall x, P (x :: nil))
         (p2 : forall x y l, P l -> P (x :: y :: l))
         (l : list A) :=
  match l return P l with
    | nil => p0
    | x :: nil => p1 x
    | x :: y :: l' => p2 x y l' (list_ind_2 P p0 p1 p2 l')
  end.

(** Osnovne lastnosti razpolavljanja. *)

Lemma razpolovi_length (l : list Z) :
  let (l1, l2) := razpolovi l in
  length l = length l1 + length l2.
Proof.
  apply (list_ind_2 (fun l =>
                            let (l1, l2) := razpolovi l in
                            length l = length l1 + length l2)).
  - simpl ; auto.
  - simpl ; auto.
  - intros x y l' H.
    simpl.
    replace (razpolovi l') with (fst (razpolovi l'), snd (razpolovi l')) in * |- * ;
      [ idtac | symmetry ; apply surjective_pairing ].
    simpl.
    rewrite <- plus_n_Sm.
    now repeat f_equal.
Qed.

(** Nekateri algoritmi za urejanje razdelijo seznam na podseznama
    glede na dani kriterij [p]. *)
Fixpoint razdeli (p : Z -> bool) (l : list Z) :=
  match l with
    | nil => (nil, nil)
    | x :: l' =>
      let (l1, l2) := razdeli p l' in
        if p x then (x :: l1, l2) else (l1, x :: l2)
  end.

(** Na primer, takole razdelimo dani seznam glede na to,
    ali so elementi večji od 5. *)
Eval compute in (razdeli (Z.leb 5) (10 :: 1 :: 1 :: 3 :: 8 :: 7 :: 5 :: nil)%Z).

Lemma razdeli_length (p : Z -> bool) (l : list Z) :
  let (l1, l2) := razdeli p l in
    length l = length l1 + length l2.
Proof.
  induction l.
  - simpl ; auto.
  - simpl.
    replace (razdeli p l) with (fst (razdeli p l), snd (razdeli p l)) in * |- * ;
      [ idtac | symmetry ; apply surjective_pairing ].
    destruct (p a) ; simpl.
    + now f_equal.
    + rewrite <- plus_n_Sm.
      now f_equal.
Qed.

(** Nekateri algoritmi izračunajo minimalni element seznama.
    Ker minimalni element praznega seznama ne obstaja, vedno
    računamo minimalni element sestavljenega seznama [x :: l].
*)
Fixpoint najmanjsi (x : Z) (l : list Z) : Z :=
  match l with
    | nil => x
    | y :: l' =>
      if Z.leb x y then najmanjsi x l' else najmanjsi y l'
  end.

Eval compute in (najmanjsi 4 (10 :: 1 :: 1 :: 3 :: 8 :: 7 :: 5 :: nil)%Z).

(** Osnovne leme o najmanjsih elementih. *)

Lemma najmanjsi_inv (x : Z) (l : list Z) :
  x = najmanjsi x l \/ In (najmanjsi x l) l.
Proof.
  generalize x.
  induction l ; auto.
  intro y.
  simpl; destruct (Z.leb y a).
  - destruct (IHl y) ; auto.
  - destruct (IHl a) ; auto.
Qed.

Lemma najmanjsi_In (x : Z) (l : list Z) :
  In (najmanjsi x l) (x :: l).
Proof.
  destruct (najmanjsi_inv x l).
  - rewrite <- H ; simpl ; auto.
  - simpl ; auto.
Qed.

Lemma najmanjsi_head (x : Z) (l : list Z) :
  (najmanjsi x l <= x)%Z.
Proof.
  generalize x.
  induction l.
  - intro ; reflexivity.
  - intro y ; simpl.
    case_eq (Z.leb y a) ; intro E.
    + apply IHl.
    + transitivity a ; [apply IHl | idtac].
      admit.
Qed.

Lemma najmanjsi_tail x y l : In y l -> (najmanjsi x l <= y)%Z.
Proof.
  generalize x y ; clear x y.
  induction l ; [intros ? ? H ; destruct H | idtac].
  intros x y H.
  apply in_inv in H ; destruct H as [G|G] ; admit.
Qed.

Lemma najmanjsi_spodna_meja (x : Z) (l : list Z) :
  forall y, In y (x :: l) -> (najmanjsi x l <= y)%Z.
Proof.
  intros y [H|H].
  - rewrite H ; apply najmanjsi_head.
  - now apply najmanjsi_tail.
Qed.