(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library 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 library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

(** Common definitions of real functions sequences. *)
Require Import Cbase.
Require Import Cfunctions.
Require Import Csequence.
Require Import Canalysis_def.

Declare Scope CFseq_scope.
Delimit Scope CFseq_scope with Cseq_scope.

Local Open Scope C_scope.
Local Open Scope CFseq_scope.

Implicit Type n : nat.
Implicit Type fn gn : nat -> C -> C.
Implicit Type f g : C -> C.

(** * Morphism of functions on R -> R to sequences. *)

Definition CFseq_plus fn gn n := (fn n + gn n)%F.
Definition CFseq_mult fn gn n := (fn n * gn n)%F.
Definition CFseq_opp fn n := (fun x => Copp (fn n x))%F.
Definition CFseq_inv fn n := (fun x => Cinv (fn n x))%F.

Infix "+" := CFseq_plus : CFseq_scope.
Infix "*" := CFseq_mult : CFseq_scope.
Notation "- u" := (CFseq_opp u) : CFseq_scope.
Notation "/ u" := (CFseq_inv u) : CFseq_scope.

Definition CFseq_minus fn gn n := (fn n - gn n)%F.
Definition CFseq_div fn gn n := (fn n / gn n)%F.

Infix "-" := CFseq_minus : CFseq_scope.
Infix "/" := CFseq_div : CFseq_scope.

(** * Convergence of functions sequences. *)

Definition CFseq_cv fn f := forall x, Cseq_cv (fun n => fn n x) (f x).
Definition CFseq_cv_boule fn f (c : C) (r : posreal) := forall x,  Boule c r x -> Cseq_cv (fun n => fn n x) (f x).

Definition CFseq_cvu fn f (x : C) (r : posreal) := forall eps : R, 0 < eps ->
        exists N : nat, forall n (y : C), (N <= n)%nat -> Boule x r y ->
        C_dist (fn n y) (f y) < eps.

Definition CFpartial_sum (fn : nat -> C) N := sum_f_C0 fn N.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

(* Why3 comment *)
(* infix_ls is replaced with (x < x1)%Z by the coq driver *)

(* Why3 goal *)
Lemma infix_lseq_def : forall (x:Z) (y:Z), (x <= y)%Z <-> ((x < y)%Z \/
  (x = y)).
exact Zle_lt_or_eq_iff.
Qed.

(* Why3 comment *)
(* infix_pl is replaced with (x + x1)%Z by the coq driver *)

(* Why3 comment *)
(* prefix_mn is replaced with (-x)%Z by the coq driver *)

(* Why3 comment *)
(* infix_as is replaced with (x * x1)%Z by the coq driver *)

(* Why3 goal *)
Lemma Assoc : forall (x:Z) (y:Z) (z:Z),
  (((x + y)%Z + z)%Z = (x + (y + z)%Z)%Z).
Proof.
intros x y z.
apply sym_eq.
apply Zplus_assoc.
Qed.

(* Why3 goal *)
Lemma Unit_def_l : forall (x:Z), ((0%Z + x)%Z = x).
Proof.
exact Zplus_0_l.
Qed.

(* Why3 goal *)
Lemma Unit_def_r : forall (x:Z), ((x + 0%Z)%Z = x).
Proof.
exact Zplus_0_r.
Qed.

(* Why3 goal *)
Lemma Inv_def_l : forall (x:Z), (((-x)%Z + x)%Z = 0%Z).
Proof.
exact Zplus_opp_l.
Qed.

(* Why3 goal *)
Lemma Inv_def_r : forall (x:Z), ((x + (-x)%Z)%Z = 0%Z).
Proof.
exact Zplus_opp_r.
Qed.

(* Why3 goal *)
Lemma Comm : forall (x:Z) (y:Z), ((x + y)%Z = (y + x)%Z).
Proof.
exact Zplus_comm.
Qed.

(* Why3 goal *)
Lemma Assoc1 : forall (x:Z) (y:Z) (z:Z),
  (((x * y)%Z * z)%Z = (x * (y * z)%Z)%Z).
Proof.
intros x y z.
apply sym_eq.
apply Zmult_assoc.
Qed.

(* Why3 goal *)
Lemma Mul_distr_l : forall (x:Z) (y:Z) (z:Z),
  ((x * (y + z)%Z)%Z = ((x * y)%Z + (x * z)%Z)%Z).
Proof.
intros x y z.
apply Zmult_plus_distr_r.
Qed.

(* Why3 goal *)
Lemma Mul_distr_r : forall (x:Z) (y:Z) (z:Z),
  (((y + z)%Z * x)%Z = ((y * x)%Z + (z * x)%Z)%Z).
Proof.
intros x y z.
apply Zmult_plus_distr_l.
Qed.

(* Why3 goal *)
Lemma infix_mn_def : forall (x:Z) (y:Z), ((x - y)%Z = (x + (-y)%Z)%Z).
reflexivity.
Qed.

(* Why3 goal *)
Lemma Comm1 : forall (x:Z) (y:Z), ((x * y)%Z = (y * x)%Z).
Proof.
exact Zmult_comm.
Qed.

(* Why3 goal *)
Lemma Unitary : forall (x:Z), ((1%Z * x)%Z = x).
Proof.
exact Zmult_1_l.
Qed.

(* Why3 goal *)
Lemma NonTrivialRing : ~ (0%Z = 1%Z).
Proof.
discriminate.
Qed.

(* Why3 goal *)
Lemma Refl : forall (x:Z), (x <= x)%Z.
Proof.
intros x.
apply Zle_refl.
Qed.

(* Why3 goal *)
Lemma Trans : forall (x:Z) (y:Z) (z:Z), (x <= y)%Z -> ((y <= z)%Z ->
  (x <= z)%Z).
Proof.
exact Zle_trans.
Qed.

(* Why3 goal *)
Lemma Antisymm : forall (x:Z) (y:Z), (x <= y)%Z -> ((y <= x)%Z -> (x = y)).
Proof.
exact Zle_antisym.
Qed.

(* Why3 goal *)
Lemma Total : forall (x:Z) (y:Z), (x <= y)%Z \/ (y <= x)%Z.
Proof.
intros x y.
destruct (Zle_or_lt x y) as [H|H].
left.
assumption.
right.
now apply Zlt_le_weak.
Qed.

(* Why3 goal *)
Lemma ZeroLessOne : (0%Z <= 1%Z)%Z.
Proof.
apply Zle_lt_or_eq_iff.
now left.
Qed.

(* Why3 goal *)
Lemma CompatOrderAdd : forall (x:Z) (y:Z) (z:Z), (x <= y)%Z ->
  ((x + z)%Z <= (y + z)%Z)%Z.
Proof.
exact Zplus_le_compat_r.
Qed.

(* Why3 goal *)
Lemma CompatOrderMult : forall (x:Z) (y:Z) (z:Z), (x <= y)%Z ->
  ((0%Z <= z)%Z -> ((x * z)%Z <= (y * z)%Z)%Z).
Proof.
exact Zmult_le_compat_r.
Qed.


(* author: Dimitur Krustev *)
(* started: 20170526 *)

(* partially inspired by: https://medium.com/@deathmood/how-to-write-your-own-virtual-dom-ee74acc13060 *)

Require Import List Arith.
Require String.
Require Fin.

Fixpoint replaceNth {A} (n: nat) (xs: list A) (y: A) {struct xs} : list A :=
  match xs with
  | nil => nil
  | x::xs => match n with
    | 0 => y::xs
    | S n => x :: replaceNth n xs y
    end
  end.

Lemma length_replaceNth: forall A (xs: list A) n y, length (replaceNth n xs y) = length xs.
Proof.
  induction xs; auto.
  simpl. intros. destruct n; auto.
  simpl. f_equal. auto.
Qed.

Lemma nth_replaceNth_sameInd: forall A (xs: list A) n y default,
  nth n (replaceNth n xs y) default =  if n <? length xs then y else default.
Proof.
  induction xs.
  - simpl. intros. destruct n; auto.
  - simpl. intros. destruct n; auto.
    simpl. rewrite IHxs. unfold Nat.ltb. reflexivity.
Qed.

Lemma nth_replaceNth_diffInd: forall A (xs: list A) n m y default,
  n <> m -> nth n (replaceNth m xs y) default = nth n xs default.
Proof.
  induction xs; auto.
  simpl. destruct m.
  - simpl. intros. destruct n; try congruence.
  - simpl. intros. destruct n; auto.
Qed.

Lemma replaceNth_app_l: forall A (xs ys: list A) n y,
  n < length xs -> replaceNth n (xs ++ ys) y = replaceNth n xs y ++ ys.
Proof.
  induction xs.
  - simpl. intros. contradict H. auto with arith.
  - simpl. intros. destruct n; auto.
    rewrite IHxs; auto with arith.
Qed.

Lemma replaceNth_app_r: forall A (xs ys: list A) n y,
  n >= length xs -> replaceNth n (xs ++ ys) y = xs ++ replaceNth (n - length xs) ys y.
Proof.
  induction xs; auto.
  - simpl. intros. rewrite <- minus_n_O. reflexivity.
  - simpl. intros. destruct n.
    + contradict H. unfold ge. auto with arith.
    + f_equal. rewrite Nat.sub_succ. auto with arith.
Qed.

(*
Fixpoint optionMap {A B: Type} (f: A -> option B) (xs: list A) : option (list B) :=
  match xs with
  | nil => Some nil
  | x::xs => match f x with
    | None => None
    | Some y => match optionMap f xs with
      | None => None
      | Some ys => Some (y::ys)
      end
    end
  end.

Section MonadOps.

Variable M: Type -> Type.
Variable mret: forall {X}, X -> M X.
Variable mbind: forall {X Y}, M X -> (X -> M Y) -> M Y.

Fixpoint mapM {A B} (f: A -> M B) (xs: list A) {struct xs} : M (list B) :=
  match xs with
  | nil => mret _ nil
  | x::xs => mbind _ _ (f x) (fun y => mbind _ _ (mapM f xs) (fun ys => mret _ (y::ys)))
  end.

End MonadOps.

Implicit Arguments mapM [M A B].
*)

(* *** *)

Inductive State (S A: Type) := MkState (f: S -> A * S).
Implicit Arguments MkState [S A].

Definition stRet {S A} (x: A) : State S A := MkState (fun s => (x, s)).
Definition stBind {S A B} (m: State S A) (f: A -> State S B) : State S B :=
  let '(MkState g) := m in MkState (fun s0 : S =>
     let '(a, s1) := g s0 in
     let '(MkState h) := f a in
     h s1).

Definition stGet {S} : State S S := MkState (fun s => (s, s)).
Definition stPut {S} (s: S) : State S unit := MkState (fun _ => (tt, s)).
Definition stRun {S A} (m: State S A) (s0: S) : A * S :=
  let '(MkState f) := m in f s0.
Definition stEval {S A} (m: State S A) s0 := fst (stRun m s0).

Notation "m >>= f" := (stBind m f) (at level 50, left associativity).
Notation "'do' a <- e ; c" := (e >>= (fun a => c)) (at level 60, right associativity).

(*
Fixpoint stMapM {S A B} (f: A -> State S B) (xs: list A) : State S (list B) :=
  match xs with
  | nil => stRet nil
  | x::xs => stBind (f x) (fun y => stBind (stMapM f xs) (fun ys => stRet (y::ys)))
  end.
*)

Require Import FunctionalExtensionality.

Lemma stBind_assoc: forall S A B C (m: State S A) (f: A -> State S B) (g: B -> State S C),
  stBind (stBind m f) g = stBind m (fun x => stBind (f x) g).
Proof.
  destruct m as [fm]. simpl. intros. f_equal. extensionality s0.
  destruct (fm s0) as [a s1]. destruct (f a) as [h]. reflexivity.
Qed.

Lemma stRun_stBind: forall S A B (m: State S A) (f: A -> State S B) s,
  stRun (stBind m f) s = let p := stRun m s in stRun (f (fst p)) (snd p).
Proof.
  destruct m as [g]. simpl. intros. destruct (g s) as [a s1].
  simpl. destruct (f a) as [h]. reflexivity.
Qed.

Lemma stEval_stBind: forall S A B (m: State S A) (f: A -> State S B) s,
  stEval (stBind m f) s = let p := stRun m s in stEval (f (fst p)) (snd p).
Proof.
  destruct m as [g]. simpl. intros. unfold stEval. simpl. destruct (g s) as [a s1].
  simpl. destruct (f a) as [h]. reflexivity.
Qed.

(* *** *)

Section VDom.

Inductive DomNodeType := TextNode | ElementNode.

Record DomOps (Dom: Type) (DomNode: Type) := MkDomOps {
  (* nodeEqDec: forall x y: DomNode, {x = y} + {x <> y}; *)
  getNodeType: DomNode -> State Dom DomNodeType;
  childrenCount: DomNode -> State Dom nat;
  getChildNode: DomNode -> nat -> State Dom DomNode;
  createTextNode: String.string -> State Dom DomNode;
  createElement: String.string -> State Dom DomNode;
  appendChild: DomNode -> DomNode -> State Dom unit;
  removeChildAt: DomNode -> nat -> State Dom unit;
  replaceChildAt: DomNode -> nat -> DomNode -> State Dom unit;
  getTagName: DomNode -> State Dom String.string;
  getText: DomNode -> State Dom String.string;
  setText: DomNode -> String.string -> State Dom unit;
  }.

Implicit Arguments getNodeType [Dom DomNode].
Implicit Arguments childrenCount [Dom DomNode].
Implicit Arguments getChildNode [Dom DomNode].
Implicit Arguments createTextNode [Dom DomNode].
Implicit Arguments createElement [Dom DomNode].
Implicit Arguments appendChild [Dom DomNode].
Implicit Arguments removeChildAt [Dom DomNode].
Implicit Arguments replaceChildAt [Dom DomNode].
Implicit Arguments getTagName [Dom DomNode].
Implicit Arguments getText [Dom DomNode].
Implicit Arguments setText [Dom DomNode].

Definition DomNode := nat.

Inductive DomNodeCell: Set  :=
  | DomText (t: String.string)
  | DomElement (name: String.string) (children: list DomNode).

Definition Dom := list DomNodeCell.

Definition getNodeCell dom node := nth node dom (DomText String.EmptyString).

Definition domOps: DomOps Dom DomNode := {|
  getNodeType node :=
    do dom <- stGet;
    match getNodeCell dom node with
    | DomText _ => stRet TextNode
    | DomElement _ _ => stRet ElementNode
    end;
  childrenCount node :=
    do dom <- stGet;
    match getNodeCell dom node with
    | DomText _ => stRet 0
    | DomElement _ children => stRet (length children)
    end;
  getChildNode node index :=
    do dom <- stGet;
    match getNodeCell dom node with
    | DomText _ => stRet 0
    | DomElement _ children => stRet (nth index children 0)
    end;
  createTextNode text :=
    do dom <- stGet;
    let len := length dom in
    do _ <- stPut (dom ++ (DomText text :: nil));
    stRet len;
  createElement tag :=
    do dom <- stGet;
    let len := length dom in
    do _ <- stPut (dom ++ (DomElement tag nil :: nil));
    stRet len;
  appendChild parent child :=
    do dom <- stGet;
    match getNodeCell dom parent with
    | DomText _ => stRet tt
    | DomElement tag children =>
        stPut (replaceNth parent dom (DomElement tag (children ++ child::nil)))
    end;
  removeChildAt node index :=
    do dom <- stGet;
    match getNodeCell dom node with
    | DomText _ => stRet tt
    | DomElement tag children =>
        stPut (replaceNth node dom (DomElement tag
          (firstn index children ++ skipn (S index) children)))
    end;
  replaceChildAt node index newChild :=
    do dom <- stGet;
    match getNodeCell dom node with
    | DomText _ => stRet tt
    | DomElement tag children =>
        stPut (replaceNth node dom (DomElement tag (replaceNth index children newChild)))
    end;
  getTagName node :=
    do dom <- stGet;
    match getNodeCell dom node with
    | DomText _ => stRet String.EmptyString
    | DomElement tag _ => stRet tag
    end;
  getText node :=
    do dom <- stGet;
    match getNodeCell dom node with
    | DomText text => stRet text
    | DomElement _ _ => stRet String.EmptyString
    end;
  setText node newText :=
    do dom <- stGet;
    match getNodeCell dom node with
    | DomText _ =>
        stPut (replaceNth node dom (DomText newText))
    | DomElement tag children => stRet tt
    end;
  |}.

(* *** *)

Inductive VDomNode :=
  VText (t: String.string) | VElement (name: String.string) (children: list VDomNode).

Fixpoint vdomDepth (node: VDomNode) : nat :=
  match node with
  | VText _ => 0
  | VElement _ children => S (fold_right max 0 (map vdomDepth children))
  end.

Section VDomNodeFullInd.

Variable P: VDomNode -> Prop.
Variable PText: forall text, P (VText text).
Variable PElement: forall name children, Forall P children -> P (VElement name children).

Fixpoint VDomNode_fullInd (node: VDomNode) : P node :=
  match node with
  | VText text => PText text
  | VElement name children =>
      PElement name _ ((fix nodesInd (nodes: list VDomNode) : Forall P nodes :=
        match nodes return Forall P nodes with
        | nil => Forall_nil _
        | node::nodes => Forall_cons node (VDomNode_fullInd node) (nodesInd nodes)
        end) children)
  end.

End VDomNodeFullInd.

(* *** *)

Fixpoint createNode (node: VDomNode) : State Dom DomNode :=
  let createNodes := fix createNodes (parent: DomNode) (nodes: list VDomNode)
    : State Dom (list DomNode) :=
    match nodes with
    | nil => stRet nil
    | node::nodes =>
      do n <- createNode node;
      do _ <- domOps.(appendChild) parent n;
      do ns <- createNodes parent nodes;
      stRet (n::ns)
    end in
  match node with
  | VText t => domOps.(createTextNode) t
  | VElement name children =>
    do el <- domOps.(createElement) name;
    do els <- createNodes el children;
    stRet el
  end.

Fixpoint removeNodes (parent: DomNode) (from: nat) (count: nat)
  {struct count} : State Dom unit :=
  match count with
  | 0 => stRet tt
  | S count =>
      do _ <- domOps.(removeChildAt) parent (count + from);
      removeNodes parent from count
  end.

Fixpoint updateNode (parent: DomNode) (newNode: VDomNode) (index: nat) {struct newNode}
  : State Dom unit :=
  let updateNodes :=
    fix updateNodes (parent: DomNode) (newNodes: list VDomNode) (index: nat)
      {struct newNodes} : State Dom unit :=
      match newNodes with
      | nil => stRet tt
      | newNode::newNodes =>
          do len <- domOps.(childrenCount) parent;
          do _ <-
            if index <? len then
              updateNode parent newNode index
            else
              do node <- createNode newNode;
              domOps.(appendChild) parent node;
          updateNodes parent newNodes (S index)
      end
    in
  do oldNode <- domOps.(getChildNode) parent index;
  do oldNodeType <- domOps.(getNodeType) oldNode;
  match newNode, oldNodeType with
  | VElement name children, ElementNode =>
      do oldName <- domOps.(getTagName) oldNode;
      if String.string_dec name oldName then
        do oldLen <- domOps.(childrenCount) oldNode;
        let newLen := length children in
        do _ <- if newLen <? oldLen then removeNodes oldNode newLen (oldLen - newLen) else stRet tt;
        updateNodes oldNode children 0
      else
        do node <- createNode newNode;
        domOps.(replaceChildAt) parent index node
  | VText text, TextNode =>
      do oldText <- domOps.(getText) oldNode;
      if String.string_dec text oldText then stRet tt
      else domOps.(setText) oldNode text
  | _, _ =>
      do node <- createNode newNode;
      domOps.(replaceChildAt) parent index node
  end.

(* *** *)

Fixpoint dom2vdom (maxDepth: nat) (root: DomNode) {struct maxDepth} : State Dom VDomNode :=
  do type <- domOps.(getNodeType) root;
  match type with
  | TextNode =>
      do text <- domOps.(getText) root;
      stRet (VText text)
  | ElementNode =>
      do tag <- domOps.(getTagName) root;
      do children <- match maxDepth with
        | 0 => stRet nil
        | S maxDepth =>
            let convChildren :=
              fix convChildren index count :=
                match count with
                | 0 => stRet nil
                | S count =>
                    do childNode <- domOps.(getChildNode) root index;
                    do vnode <- dom2vdom maxDepth childNode;
                    do vnodes <- convChildren (S index) count;
                    stRet (vnode::vnodes)
                end
              in
            do count <- domOps.(childrenCount) root;
            convChildren 0 count
        end;
      stRet (VElement tag children)
  end.

Definition ValidDomNode (dom: Dom) (node: DomNode) : Prop := node < length dom.

Definition ValidDom (dom: Dom) : Prop :=
  exists nodeDepth: DomNode -> nat,
    forall node: DomNode, exists tag children,
      getNodeCell dom node = DomElement tag children ->
      forall child, In child children -> nodeDepth child > nodeDepth node.

Lemma createNode_correct: forall vnode,
  exists f, createNode vnode = MkState f
    /\ forall dom, exists dom1, f dom = (length dom, dom ++ dom1)
      /\ forall dom2, length dom = length dom2 ->
          stEval (dom2vdom (vdomDepth vnode) (length dom)) (dom2 ++ dom1) = vnode.
Proof.
  intros. exists (stRun (createNode vnode)).
  induction vnode using VDomNode_fullInd.
  - simpl. intros. split; auto. intros.
    exists (DomText text :: nil). split; auto. intros.
    unfold stEval, stRun. unfold getNodeCell at 1.
    rewrite app_nth2; try (rewrite H; auto with arith).
    rewrite <- minus_diag_reverse. simpl.
    unfold getNodeCell at 1.
    rewrite app_nth2; auto with arith.
    rewrite <- minus_diag_reverse. reflexivity.
  - split; auto. unfold createNode. fold createNode.
    assert (HcreateNodes: forall dom dom1 tag nodes0 depth,
      depth > fold_right max 0 (map vdomDepth children) ->
      exists nodes, exists dom2,
      (stRun ((fix createNodes (parent : DomNode) (nodes : list VDomNode) {struct nodes} :
        State Dom (list DomNode) :=
        match nodes with
        | nil => stRet nil
        | node :: nodes0 =>
            do n <- createNode node;
            do _ <- appendChild domOps parent n;
            do ns <- createNodes parent nodes0; stRet (n :: ns)
        end) (length dom) children) (dom ++ DomElement tag nodes0 :: dom1)
        = (nodes, dom ++ DomElement tag (nodes0 ++ nodes) :: dom1 ++ dom2)
      /\ forall dom3, length dom = length dom3 ->
        Forall2 (fun node child => stEval (dom2vdom depth node)
            (dom3 ++ DomElement tag (nodes0 ++ nodes) :: dom1 ++ dom2) = child)
          nodes children)).
    { clear name. revert H. induction children.
      - simpl. intros. exists nil. exists nil. intros.
        repeat (rewrite app_nil_r). split; auto.
      - intros. inversion H. subst.
        rewrite stRun_stBind. destruct H3 as [Hcn1 Hcn2].
        specialize (Hcn2 (dom ++ DomElement tag nodes0 :: dom1)).
        destruct Hcn2 as [dom2 [Hcn2 Hcn3]].
        rewrite app_length in Hcn2. simpl in Hcn2. rewrite plus_comm in Hcn2.
        simpl in Hcn2. rewrite Hcn2. cbn [fst snd].
        rewrite stRun_stBind. unfold stRun at 1.
        unfold appendChild at 2.
        cbn [domOps].
        unfold stBind at 5. unfold stGet at 1.
        unfold getNodeCell. rewrite <- app_assoc. cbn [app].
        rewrite app_nth2; auto with arith.
        rewrite <- minus_diag_reverse. cbn [nth].
        unfold stPut at 1.
        rewrite replaceNth_app_r; auto with arith.
        rewrite <- minus_diag_reverse. cbn [replaceNth snd app].
        rewrite stRun_stBind.
        simpl in H0.
        specialize (IHchildren H4).
        assert (Hgt: depth > fold_right Init.Nat.max 0 (map vdomDepth children)).
        { unfold gt in *. rewrite Nat.max_lub_lt_iff in H0.
          destruct H0. assumption. }
        specialize (IHchildren dom (dom1 ++ dom2) tag
          (nodes0 ++ S (length dom1 + length dom) :: nil) depth Hgt).
        destruct IHchildren as [nodes [dom3 [IH1 IH2]]].
        rewrite IH1. simpl.
        exists (S (length dom1 + length dom) :: nodes). simpl.
        exists (dom2 ++ dom3).
        split.
        + f_equal. f_equal.
          repeat (rewrite <- app_assoc). reflexivity.
        + intros. constructor.
          * rewrite app_length in Hcn3. simpl in Hcn3.
            admit.
          * admit.
    }
    intros.
    assert (Hgt: vdomDepth (VElement name children) >
     fold_right Init.Nat.max 0 (map vdomDepth children)); auto with arith.
    destruct (HcreateNodes dom nil name nil
      (vdomDepth (VElement name children)) Hgt) as [nodes [dom1 [Hcns1 Hcns2]]].
    exists (DomElement name nodes :: dom1).
    split.
    { rewrite stRun_stBind. unfold domOps at 1. unfold createElement.
      repeat (rewrite stRun_stBind).
      remember (fix createNodes (parent : DomNode) (nodes : list VDomNode) {struct nodes} :
        State Dom (list DomNode) :=
        match nodes with
        | nil => stRet nil
        | node :: nodes0 =>
            do n <- createNode node;
            do _ <- appendChild domOps parent n;
            do ns <- createNodes parent nodes0; stRet (n :: ns)
        end)
        as createNodes.
      simpl. f_equal.
      subst.
      rewrite Hcns1. reflexivity.
    }
    { simpl. intros. unfold stEval, stRun. rewrite H0.
      unfold getNodeCell at 1.
      rewrite app_nth2; auto with arith.
      rewrite <- minus_diag_reverse. simpl.
      unfold getNodeCell at 1.
      rewrite app_nth2; auto with arith.
      rewrite <- minus_diag_reverse. simpl.
      unfold getNodeCell at 1.
      rewrite app_nth2; auto with arith.
      rewrite <- minus_diag_reverse. simpl.
      admit.
    }
Admitted.

Theorem updateNode_correct: forall vdom dom parent index,
  ValidDomNode dom parent ->
  stEval (domOps.(getNodeType) parent) dom = ElementNode ->
  index < stEval (domOps.(childrenCount) parent) dom ->
  stEval (
    do _ <- updateNode parent vdom index;
    do node <- domOps.(getChildNode) parent index;
    dom2vdom (vdomDepth vdom) node) dom
  = vdom.
Proof.
  induction vdom using VDomNode_fullInd.
  - simpl. intros. unfold stEval, stRun in *.
    destruct (getNodeCell dom parent) as [oldText | parentTag nodes] eqn: Heq;
      try (simpl in *; congruence).
    unfold stRet in *. simpl in *.
    destruct (getNodeCell dom (nth index nodes 0)) as [oldText | tag children] eqn: Heq1.
    + rewrite Heq1. destruct (String.string_dec text oldText) as [Heq2 | Hneq].
      * subst. rewrite Heq. repeat (rewrite Heq1). reflexivity.
      * rewrite Heq1. unfold stPut. unfold getNodeCell at 1.
        rewrite nth_replaceNth_diffInd.
        2: admit. (* try to use [ValidDom]/[nodeDepth] to discharge *)
        fold (getNodeCell dom parent).
        rewrite Heq. unfold getNodeCell at 1.
        rewrite nth_replaceNth_sameInd.
        destruct (nth index nodes 0 <? length dom) eqn: Hltb.
        2: admit.
        unfold getNodeCell at 1.
        rewrite nth_replaceNth_sameInd.
        rewrite Hltb. reflexivity.
    + unfold getNodeCell at 1. rewrite app_nth1; auto.
      fold (getNodeCell dom parent).
      rewrite Heq. unfold stPut.
      unfold getNodeCell at 1.
      rewrite nth_replaceNth_sameInd.
      rewrite app_length. simpl. rewrite plus_comm. simpl.
      destruct (parent <? S (length dom)) eqn: Hltb.
      2: admit.
      rewrite nth_replaceNth_sameInd.
      destruct (index <? length nodes) eqn: Hltb1.
      2: admit.
      unfold getNodeCell at 1.
      rewrite replaceNth_app_l; auto.
      rewrite app_nth2.
      2: rewrite length_replaceNth; auto with arith.
      rewrite length_replaceNth. rewrite <- minus_diag_reverse. simpl.
      unfold getNodeCell at 1.
      rewrite app_nth2.
      2: rewrite length_replaceNth; auto with arith.
      rewrite length_replaceNth. rewrite <- minus_diag_reverse. reflexivity.
  - cbn -[createNode updateNode dom2vdom].
    intros. unfold stEval, stRun in *.
    cbn -[createNode dom2vdom].
    destruct (getNodeCell dom parent) as [oldText | parentTag nodes] eqn: Heq;
      try (simpl in *; congruence).
    unfold stRet in *. simpl in * |-.
    destruct (getNodeCell dom (nth index nodes 0)) as [text | tag oldChildren] eqn: Heq1.
    + unfold stBind.
      destruct (createNode_correct (VElement name children)) as [f [Heqcn Hcn]].
      rewrite Heqcn. destruct (Hcn dom) as [dom1 [Heqcn1 Heqcn2]].
      rewrite Heqcn1. unfold getNodeCell at 1.
      rewrite app_nth1; auto with arith.
      fold (getNodeCell dom parent). rewrite Heq.
      unfold stPut. rewrite replaceNth_app_l; auto.
      unfold getNodeCell at 1.
      rewrite app_nth1.
      2: rewrite length_replaceNth; auto with arith.
      rewrite nth_replaceNth_sameInd.
      destruct (parent <? length dom) eqn: Hltb.
      2: admit.
      unfold stEval, stRun, vdomDepth in Heqcn2. fold vdomDepth in Heqcn2.
      rewrite nth_replaceNth_sameInd.
      destruct (index <? length nodes) eqn: Hltb1.
      2: admit.
      rewrite Heqcn2; auto.
      rewrite length_replaceNth. reflexivity.
    + admit.

Qed.

End VDom.


Require Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Export Coq.Classes.Equivalence.
Require Export Coq.Sets.Ensembles.
Require Import Coq.Sets.Constructive_sets.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.EquivDec_ext.

Lemma Full_set_spec: forall A (v: A), Full_set A v <-> True.
Proof.
  intros.
  split; intros; constructor.
Qed.

Lemma Empty_set_spec: forall A (v: A), Empty_set A v <-> False.
  intros.
  split; intros [].
Qed.

Lemma Intersection_spec: forall A (v: A) P Q, Intersection _ P Q v <-> P v /\ Q v.
Proof.
  intros.
  split; intros.
  + inversion H; auto.
  + constructor; tauto.
Qed.

Lemma Union_spec: forall A (v: A) P Q, Union _ P Q v <-> P v \/ Q v.
Proof.
  intros.
  split; intros.
  + inversion H; auto.
  + destruct H; [apply Union_introl | apply Union_intror]; auto.
Qed.

Lemma Disjoint_spec: forall A P Q, Disjoint A P Q <-> (forall x, P x -> Q x -> False).
Proof.
  intros; split; intros.
  + inversion H.
    eapply H2.
    unfold In; rewrite Intersection_spec; split; eauto.
  + constructor.
    intros.
    unfold In; rewrite Intersection_spec.
    intro; apply H with x; tauto.
Qed.

Lemma Included_Full_set: forall A P, Included A P (Full_set A).
Proof.
  intros.
  hnf; unfold In; intros.
  apply Full_set_spec; auto.
Qed.

Lemma Intersection_Complement: forall A (P Q: Ensemble A),
  Same_set A
  (Intersection A (Complement A P) (Complement A Q))
  (Complement A (Union A P Q)).
Proof.
  intros.
  unfold Same_set, Included, Complement, Ensembles.In.
  split; intros.
  + rewrite Union_spec.
    rewrite Intersection_spec in H.
    tauto.
  + rewrite Union_spec in H.
    rewrite Intersection_spec.
    tauto.
Qed.

Lemma Union_iff: forall U A B x, Ensembles.In U (Union U A B) x <-> Ensembles.In U A x \/ Ensembles.In U B x.
Proof.
  intros; split; intros.
  + apply Constructive_sets.Union_inv; auto.
  + destruct H; [apply Union_introl | apply Union_intror]; auto.
Qed.

Lemma Empty_set_iff: forall U x, Ensembles.In U (Empty_set U) x <-> False.
Proof.
  intros; split; intro; inversion H.
Qed.

Lemma Singleton_iff: forall U x y, Ensembles.In U (Singleton U x) y <-> x = y.
Proof.
  intros; split; intro.
  + inversion H; auto.
  + subst; constructor.
Qed.

Arguments Included {U} B C.
Arguments Same_set {U} B C.

Lemma Same_set_refl: forall A (S : Ensemble A), Same_set S S. Proof. intros; split; intro; tauto. Qed.

Lemma Same_set_sym: forall A (S1 S2 : Ensemble A), Same_set S1 S2 -> Same_set S2 S1. Proof. intros; destruct H; split; auto. Qed.

Lemma Same_set_trans: forall A (S1 S2 S3: Ensemble A), Same_set S1 S2 -> Same_set S2 S3 -> Same_set S1 S3.
Proof. intros; destruct H, H0; split; repeat intro; [apply H0, H, H3 | apply H1, H2, H3]. Qed.

Add Parametric Relation {A} : (Ensemble A) Same_set
    reflexivity proved by (Same_set_refl A)
    symmetry proved by (Same_set_sym A)
    transitivity proved by (Same_set_trans A) as Same_set_rel.

Lemma Same_set_spec: forall A P Q, Same_set P Q <-> (pointwise_relation A iff) P Q.
Proof.
  intros.
  unfold Same_set, Included, In, pointwise_relation.
  firstorder.
Qed.

Lemma Complement_Empty_set: forall A, Same_set (Complement A (Empty_set _)) (Full_set _).
Proof.
  intros.
  rewrite Same_set_spec.
  intro a.
  unfold Complement, Ensembles.In.
  pose proof Empty_set_iff _ a.
  pose proof Full_set_spec _ a.
  tauto.
Qed.

Lemma Intersection_comm: forall A P Q, Same_set (Intersection A P Q) (Intersection A Q P).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Intersection_spec.
  tauto.
Qed.

Lemma Intersection_assoc: forall A P Q R, Same_set (Intersection A (Intersection A P Q) R) (Intersection A P (Intersection A Q R)).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Intersection_spec.
  tauto.
Qed.

Lemma Union_comm: forall A P Q, Same_set (Union A P Q) (Union A Q P).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Union_spec.
  tauto.
Qed.

Lemma Union_assoc: forall A P Q R, Same_set (Union A (Union A P Q) R) (Union A P (Union A Q R)).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Union_spec.
  tauto.
Qed.

Lemma Intersection_Union_distr_l: forall A P Q R,
  Same_set (Intersection A (Union A Q R) P)
   (Union A (Intersection A Q P) (Intersection A R P)).
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite !Intersection_spec, !Union_spec, !Intersection_spec.
  tauto.
Qed.

Lemma Intersection_Union_distr_r: forall A P Q R,
  Same_set (Intersection A P (Union A Q R))
   (Union A (Intersection A P Q) (Intersection A P R)).
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite !Intersection_spec, !Union_spec, !Intersection_spec.
  tauto.
Qed.

Instance Included_proper (V: Type): Proper (Same_set ==> Same_set ==> iff) (@Included V).
Proof.
  hnf; intros.
  hnf; intros.
  rewrite Same_set_spec in *.
  unfold pointwise_relation, Included, Ensembles.In in *.
  firstorder.
Defined.

Instance complement_proper (V: Type): Proper (Same_set ==> Same_set) (Complement V).
  hnf; intros.
  rewrite Same_set_spec in *.
  hnf; intros.
  unfold Complement, Ensembles.In.
  specialize (H a).
  tauto.
Defined.

Instance Union_proper (V: Type): Proper (Same_set ==> Same_set ==> Same_set) (Union V).
  hnf; intros.
  hnf; intros.
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *; intros.
  rewrite !Union_spec.
  firstorder.
Defined.

Instance Disjoint_proper (V: Type): Proper (Same_set ==> Same_set ==> iff) (Disjoint V).
  hnf; intros.
  hnf; intros.
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  rewrite !Disjoint_spec.
  firstorder.
Defined.

Lemma Union_Included {A: Type}: forall P Q R, Included (Union A P Q) R <-> Included P R /\ Included Q R.
Proof.
  intros.
  unfold Included.
  pose proof Union_iff A P Q.
  firstorder.
Qed.

Lemma left_Included_Union {A: Type}: forall P Q, Included P (Union A P Q).
Proof.
  intros.
  intros ? ?.
  rewrite Union_iff.
  tauto.
Qed.

Lemma right_Included_Union {A: Type}: forall P Q, Included Q (Union A P Q).
Proof.
  intros.
  intros ? ?.
  rewrite Union_iff.
  tauto.
Qed.

Lemma Union_Empty_left {A: Type}: forall P, Same_set (Union _ (Empty_set A) P) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Union_spec.
  pose proof Noone_in_empty A a.
  tauto.
Qed.

Lemma Union_Empty_right {A: Type}: forall P, Same_set (Union _ P (Empty_set A)) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Union_spec.
  pose proof Noone_in_empty A a.
  tauto.
Qed.

Lemma Intersection_Full_left {A: Type}: forall P, Same_set (Intersection _ (Full_set A) P) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Full_set_spec A a.
  tauto.
Qed.

Lemma Intersection_Full_right {A: Type}: forall P, Same_set (Intersection _ P (Full_set A)) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Full_set_spec A a.
  tauto.
Qed.

Lemma Intersection_Empty_left {A: Type}: forall P, Same_set (Intersection _ (Empty_set A) P) (Empty_set A).
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Empty_set_spec A a.
  tauto.
Qed.

Lemma Intersection_Empty_right {A: Type}: forall P, Same_set (Intersection _ P (Empty_set A)) (Empty_set A).
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Empty_set_spec A a.
  tauto.
Qed.

Lemma Intersection_absort_right: forall U (A B: Ensemble U), Included A B -> Same_set (Intersection _ A B) A.
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite Intersection_spec.
  specialize (H x); unfold Ensembles.In in H.
  tauto.
Qed.

Lemma Intersection_absort_left: forall U (A B: Ensemble U), Included B A -> Same_set (Intersection _ A B) B.
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite Intersection_spec.
  specialize (H x); unfold Ensembles.In in H.
  tauto.
Qed.

Lemma Complement_Included_rev: forall (U: Type) P Q, Included P Q -> Included (Complement U Q) (Complement U P).
Proof.
  unfold Included, Complement, Ensembles.In.
  intros.
  firstorder.
Qed.

Lemma Prop_join_shrink: forall {U} (A B C R: Ensemble U),
  Included B R ->
  Prop_join A B C ->
  Prop_join (Intersection _ A R) B (Intersection _ C R).
Proof.
  unfold Prop_join, Included, Ensembles.In.
  intros.
  split; intros; rewrite !Intersection_spec in *; auto.
  + split; firstorder.
  + firstorder.
Qed.

Lemma Prop_join_shrink1: forall {U} (A B C: Ensemble U) (x: U),
  A x ->
  Prop_join A B C ->
  Prop_join (Intersection _ A (fun x0 => x <> x0)) B (Intersection _ C (fun x0 => x <> x0)).
Proof.
  intros.
  apply Prop_join_shrink; auto.
  unfold Included, In; intros.
  intro.
  subst x0.
  destruct H0.
  apply (H2 x); auto.
Qed.

Lemma Ensemble_join_Intersection_Complement: forall {A} P Q,
  Included Q P ->
  (forall x, Q x \/ ~ Q x) ->
  Prop_join Q (Intersection A P (Complement A Q)) P.
Proof.
  intros.
  unfold Prop_join.
  unfold Included, Ensembles.In in H.
  split; intros x; specialize (H0 x); specialize (H x);
  rewrite Intersection_spec; unfold Complement, Ensembles.In; try tauto.
Qed.

Instance Intersection_proper {A}: Proper (Same_set ==> Same_set ==> Same_set) (Intersection A).
Proof.
  do 2 (hnf; intros).
  rewrite Same_set_spec in *.
  intro a; specialize (H0 a); specialize (H a).
  rewrite !Intersection_spec.
  tauto.
Defined.

Instance Prop_join_proper {A}: Proper (@Same_set A ==> Same_set ==> Same_set ==> iff) Prop_join.
Proof.
  intros.
  do 3 (hnf; intros).
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  split; intros [? ?]; split; intro; firstorder.
Defined.

Lemma Included_Disjoint: forall A P Q P' Q',
  Included P P' ->
  Included Q Q' ->
  Disjoint A P' Q' ->
  Disjoint A P Q.
Proof.
  intros.
  rewrite Disjoint_spec in H1 |- *.
  intros; apply (H1 x).
  + apply H; auto.
  + apply H0; auto.
Qed.

Lemma Union_left_Disjoint: forall A P Q R,
  Disjoint A (Union A P Q) R <-> Disjoint A P R /\ Disjoint A Q R.
Proof.
  intros.
  rewrite !Disjoint_spec.
  pose proof (fun x => Union_spec A x P Q).
  firstorder.
Qed.

Lemma Union_right_Disjoint: forall A P Q R,
  Disjoint A R (Union A P Q) <-> Disjoint A R P /\ Disjoint A R Q.
Proof.
  intros.
  rewrite !Disjoint_spec.
  pose proof (fun x => Union_spec A x P Q).
  firstorder.
Qed.

Lemma Included_Complement_Disjoint: forall A P Q,
  (Included P (Complement _ Q)) <-> Disjoint A P Q.
Proof.
  intros.
  unfold Included, Complement, In.
  rewrite Disjoint_spec.
  firstorder.
Qed.

Lemma Disjoint_comm: forall A P Q,
  Disjoint A P Q <-> Disjoint A Q P.
Proof.
  intros.
  rewrite !Disjoint_spec.
  firstorder.
Qed.

Lemma Disjoint_Empty_set_right: forall {A} (P: Ensemble A), Disjoint A P (Empty_set A).
Proof.
  intros.
  rewrite Disjoint_comm.
  apply Included_Complement_Disjoint.
  apply Constructive_sets.Included_Empty.
Qed.

Lemma Disjoint_Empty_set_left: forall {A} (P: Ensemble A), Disjoint A (Empty_set A) P.
Proof.
  intros.
  apply Included_Complement_Disjoint.
  apply Constructive_sets.Included_Empty.
Qed.

Lemma Disjoint_x1: forall {U} {UE: EqDec U eq} (A B: Ensemble U) (x0: U),
  Disjoint U (fun x: U => A x /\ x0 <> x) B ->
  ~ B x0 ->
  Disjoint U A B.
Proof.
  intros.
  rewrite Disjoint_spec in H |- *.
  intros.
  specialize (H x).
  destruct_eq_dec x0 x; [subst |]; tauto.
Qed.

Lemma Disjoint_x1': forall {U} {UE: EqDec U eq} (A B: Ensemble U) (x0: U),
  Disjoint U (Intersection _ A (fun x: U => x0 <> x)) B ->
  ~ B x0 ->
  Disjoint U A B.
Proof.
  intros.
  rewrite Disjoint_spec in H |- *.
  intros.
  specialize (H x).
  rewrite Intersection_spec in H.
  destruct_eq_dec x0 x; [subst |]; tauto.
Qed.

Lemma Included_trans: forall {A} (P Q R: Ensemble A), Included P Q -> Included Q R -> Included P R.
Proof.
  unfold Included, Ensembles.In.
  intros; firstorder.
Qed.

Lemma Intersection1_Included: forall {A} P Q R, Included P R -> Included (Intersection A P Q) R.
Proof.
  unfold Included, Ensembles.In.
  intros.
  rewrite Intersection_spec in H0.
  firstorder.
Qed.

Lemma Intersection2_Included: forall {A} P Q R, Included Q R -> Included (Intersection A P Q) R.
Proof.
  unfold Included, Ensembles.In.
  intros.
  rewrite Intersection_spec in H0.
  firstorder.
Qed.

Lemma Included_refl: forall A P, @Included A P P.
Proof.
  intros; hnf; auto.
Qed.

Lemma Prop_join_Disjoint:
  forall {A : Type} (P Q R : Ensemble A),
  Prop_join P Q R -> Disjoint A P Q.
Proof.
  intros.
  destruct H.
  rewrite Disjoint_spec; auto.
Qed.

Lemma Prop_join_assoc: forall A (P1 P2 P3 Q R: A -> Prop),
  Prop_join P1 Q P2 ->
  Prop_join P2 R P3 ->
  Prop_join P1 (Union _ Q R) P3.
Proof.
  unfold Prop_join.
  intros.
  destruct H, H0.
  split; intro a; rewrite Union_spec.
  + rewrite H0, H.
    tauto.
  + intros.
    destruct H4; firstorder.
Qed.

Lemma Prop_join_comm: forall {A : Type} (P Q R : Ensemble A),
  Prop_join P Q R <-> Prop_join Q P R.
Proof.
  intros.
  unfold Prop_join.
  firstorder.
Qed.

Lemma Disjoint_Union_Prop_join: forall A P Q, Disjoint A P Q -> Prop_join P Q (Union A P Q).
Proof.
  intros.
  rewrite Disjoint_spec in H.
  split.
  + intros; rewrite Union_spec; tauto.
  + auto.
Qed.

Lemma Prop_join_Empty: forall {U} (A: Ensemble U), Prop_join A (Empty_set _) A.
Proof.
  intros.
  split; intros.
  + rewrite Empty_set_spec.
    tauto.
  + rewrite Empty_set_spec in H0; auto.
Qed.

Lemma Prop_join_x1: forall {U} (A: Ensemble U) (a: U),
  ~ A a ->
  Prop_join A (eq a) (fun x => A x \/ x = a).
Proof.
  intros.
  split; intros.
  + assert (a = a0 <-> a0 = a) by (split; intros; congruence).
    tauto.
  + subst; auto.
Qed.

Definition app_same_set {A: Type} {P Q: Ensemble A} (H: Same_set P Q) (x: A): P x <-> Q x := proj1 (Same_set_spec A P Q) H x.

Coercion app_same_set : Same_set >-> Funclass.

(* TODO: rename it into preimage set *)
Definition respectful_set {A B: Type} (X: Ensemble B) (f: A -> B): Ensemble A := fun x => X (f x).

Inductive image_set {A B: Type}: Ensemble A -> (A -> B) -> Ensemble B :=
  | image_set_intro: forall (X: Ensemble A) (f: A -> B) (x: A), X x -> image_set X f (f x).

Lemma image_set_spec: forall {A B: Type} f X (y: B),
  image_set X f y <-> exists x: A, X x /\ y = f x.
Proof.
  intros.
  split; intros.
  + inversion H; subst.
    exists x.
    split; auto.
  + destruct H as [x [?H ?H]].
    subst.
    constructor; auto.
Qed.

Instance respectful_set_proper {A B: Type}: Proper (Same_set ==> pointwise_relation A (@eq B) ==> Same_set) respectful_set.
Proof.
  intros.
  do 2 (hnf; intros).
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  unfold respectful_set.
  firstorder.
  + rewrite <- H, <- H0; firstorder.
  + rewrite H, H0; firstorder.
Qed.

Instance image_set_proper2 {A B: Type}: Proper (Same_set ==> eq ==> Same_set) (@image_set A B).
Proof.
  intros.
  do 2 (hnf; intros).
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  intros.
  rewrite !image_set_spec.
  firstorder.
  + subst. firstorder.
  + subst. firstorder.
Qed.

Lemma resp_Included: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Included X Y ->
  Included (respectful_set X f) (respectful_set Y f).
Proof.
  intros.
  unfold respectful_set, Included, In.
  intro x.
  apply H.
Qed.

Lemma resp_Same_set: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Same_set X Y ->
  Same_set (respectful_set X f) (respectful_set Y f).
Proof.
  intros.
  unfold Same_set in *.
  split; apply resp_Included; tauto.
Qed.

Lemma resp_Intersection: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Same_set
   (respectful_set (Intersection _ X Y) f)
   (Intersection _ (respectful_set X f) (respectful_set Y f)).
Proof.
  intros.
  rewrite Same_set_spec; intros x.
  unfold respectful_set.
  rewrite !Intersection_spec.
  reflexivity.
Qed.

Lemma resp_Union: forall {A B: Type} (X Y: Ensemble B) (f: A -> B) ,
  Same_set
   (respectful_set (Union _ X Y) f)
   (Union _ (respectful_set X f) (respectful_set Y f)).
Proof.
  intros.
  rewrite Same_set_spec; intros x.
  unfold respectful_set.
  rewrite !Union_spec.
  reflexivity.
Qed.

Lemma resp_Complement: forall {A B: Type} (X: Ensemble B) (f: A -> B),
  Same_set
   (respectful_set (Complement _ X) f)
   (Complement _ (respectful_set X f)).
Proof.
  intros.
  rewrite Same_set_spec; intros x.
  unfold respectful_set, Complement, In.
  reflexivity.
Qed.

Lemma resp_Disjoint: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Disjoint _ X Y ->
  Disjoint _ (respectful_set X f) (respectful_set Y f).
Proof.
  intros.
  rewrite <- Included_Complement_Disjoint in *.
  rewrite <- resp_Complement.
  apply resp_Included; auto.
Qed.

Lemma resp_Empty: forall {A B: Type} (f: A -> B),
  Same_set (respectful_set (Empty_set _) f) (Empty_set _).
Proof.
  intros.
  rewrite Same_set_spec.
  intro x.
  pose proof Noone_in_empty A.
  pose proof Noone_in_empty B.
  firstorder.
Qed.

Lemma image_Included: forall {A B: Type} (f: A -> B) (X Y: Ensemble A),
  Included X Y ->
  Included (image_set X f) (image_set Y f).
Proof.
  intros.
  unfold Included, In.
  intro y.
  rewrite !image_set_spec.
  intros [x [? ?]].
  exists x; split; auto.
  apply H; auto.
Qed.

Lemma image_Same_set: forall {A B: Type} (f: A -> B) (X Y: Ensemble A),
  Same_set X Y ->
  Same_set (image_set X f) (image_set Y f).
Proof.
  intros.
  unfold Same_set in *.
  split; apply image_Included; tauto.
Qed.

Lemma image_Intersection: forall {A B: Type} (X Y: Ensemble A) (f: A -> B),
  Included
   (image_set (Intersection _ X Y) f)
   (Intersection _ (image_set X f) (image_set Y f)).
Proof.
  intros.
  unfold Included, In; intros y.
  rewrite !Intersection_spec, !image_set_spec.
  intros [x [? ?]].
  rewrite Intersection_spec in H.
  split; exists x; tauto.
Qed.

Lemma image_Union: forall {A B: Type} (X Y: Ensemble A) (f: A -> B),
  Same_set
   (image_set (Union _ X Y) f)
   (Union _ (image_set X f) (image_set Y f)).
Proof.
  intros.
  rewrite Same_set_spec; intros y.
  rewrite !Union_spec, !image_set_spec.
  pose proof (fun x => Union_spec A x X Y).
  firstorder.
Qed.

Lemma image_Disjoint_rev: forall {A B: Type} (X Y: Ensemble A) (f: A -> B),
  Disjoint _ (image_set X f) (image_set Y f) ->
  Disjoint _ X Y.
Proof.
  intros.
  rewrite Disjoint_spec in *.
  intros x ? ?.
  apply (H (f x)); constructor; auto.
Qed.

Lemma image_Empty: forall {A B: Type} (f: A -> B),
  Same_set (image_set (Empty_set _) f) (Empty_set _).
Proof.
  intros.
  rewrite Same_set_spec.
  intro x.
  rewrite image_set_spec.
  pose proof Noone_in_empty A.
  pose proof Noone_in_empty B.
  firstorder.
Qed.

Lemma image_single: forall {A B: Type} (a: A) (f: A -> B),
  Same_set (image_set (eq a) f) (eq (f a)).
Proof.
  intros.
  rewrite Same_set_spec.
  intro x.
  rewrite image_set_spec.
  split; intros; eauto.
  destruct H as [? [? ?]]; subst; auto.
Qed.

Definition Countable_Union (A: Type) (P: nat -> Ensemble A) : Ensemble A :=
  fun x => exists i, P i x.

Definition Non_Empty {U: Type} (A: Ensemble U): Prop := exists x, A x.

Definition Binart_set_list (U: Type) (A B: Ensemble U): nat -> Ensemble U :=
  fun n => match n with | 0 => A | 1 => B | _ => Empty_set _ end.

Lemma Union_is_Countable_Union: forall {U: Type} (A B: Ensemble U),
  Same_set (Union _ A B) (Countable_Union _ (Binart_set_list _ A B)).
Proof.
  intros.
  rewrite Same_set_spec.
  intros x.
  rewrite Union_spec; unfold Countable_Union.
  split.
  + intros [? | ?].
    - exists 0; auto.
    - exists 1; auto.
  + intros [[ | [ | ]] ?].
    - left; auto.
    - right; auto.
    - intros; inversion H.
Qed.

Lemma Intersection_is_Complement_Union (classic: forall P: Prop, P \/ ~ P): forall {U: Type} (A B: Ensemble U),
  Same_set (Intersection _ A B) (Complement _ (Union _ (Complement _ A) (Complement _ B))).
Proof.
  intros.
  rewrite Same_set_spec.
  intros x; unfold Complement, Ensembles.In.
  rewrite Union_spec, Intersection_spec.
  destruct (classic (A x)), (classic (B x)); tauto.
Qed.

(*

Lemma Finite_spec: forall A U, Finite A U <-> exists l, NoDup l /\ forall x, In x l <-> Ensembles.In A U x.
Proof.
  intros.
  split; intros.
  + induction H.
    - exists nil.
      split; [constructor |].
      intros.
      rewrite Empty_set_iff; simpl; tauto.
    - destruct IHFinite as [l [? ?]].
      exists (x :: l).
      split; [constructor; auto; rewrite H2; auto |].
      intros x0; specialize (H2 x0).
      simpl.
      unfold Add.
      rewrite Union_iff, Singleton_iff.
      tauto.
  + destruct H as [l [? ?]].
    revert U H0; induction l; intros.
    - replace U with (Empty_set A); [apply Empty_is_finite |].
      apply Extensionality_Ensembles.
      split; intros x ?; specialize (H0 x); simpl in *; repeat rewrite Empty_set_iff in *; tauto.
    - replace U with (Add A (Subtract A U a) a);
      [apply Union_is_finite | apply Extensionality_Ensembles].
      * inversion H; subst.
        apply IHl; [auto |].
        intros x; specialize (H0 x).
        unfold Subtract, Setminus; unfold Ensembles.In at 1.
        simpl in H0.
        rewrite Singleton_iff.
        assert (a = x -> ~ In x l) by (intro; subst; auto).
        tauto.
      * unfold Subtract, Setminus; unfold Ensembles.In at 1.
        rewrite Singleton_iff.
        tauto.
      * unfold Add, Subtract, Setminus.
        split; intros ?; rewrite Union_iff;
          [unfold Ensembles.In at 1 | unfold Ensembles.In at 2];
          rewrite  Singleton_iff; intro;
          specialize (H0 x); simpl in H0; [tauto |].
        inversion H; subst.
        assert (a = x -> ~ In x l) by (intro; subst; auto).
        tauto.
Qed.

*)


(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 2 *)

Require Import Frap.

(* Authors:
 * Ben Sherman (sherman@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

(** * Polymorphic container types *)

(* In this problem set, we'll get some practice using some of the
 * polymorphic container types that we saw in Lecture 2, in particular,
 * [option], [list], and [tree]. We'll then use [tree] and [option]
 * together to create binary tries (i.e., finite maps keyed by lists of
 * Booleans).
 *
 * First, we'll reproduce some definitions we need from Lecture 2,
 * [tree] and [flatten]:
 *)

Inductive tree {A} :=
| Leaf
| Node (l : tree) (d : A) (r : tree).
Arguments tree : clear implicits.

Fixpoint flatten {A} (t : tree A) : list A :=
  match t with
  | Leaf => []
  | Node l d r => flatten l ++ d :: flatten r
  end.

(* And here's one additional definition that we'll use in this problem set.
 * [either] combines two [option] values into one.
 * If either argument to [either] is a [Some], then so is
 * the result of the [either], preferring the contents of
 * the first argument if both are [Some].
 *
 * We will observe an "analogy" between the [either]
 * function on options and the [++] function on lists.
 *)
Definition either {A} (xo yo : option A) : option A :=
  match xo with
  | None => yo
  | Some x => Some x
  end.

(* A binary trie is a finite map keyed by lists of Booleans.
 * We will implement a binary trie with entries of type [A]
 * by [tree (option A)]. The value at the root of the tree
 * corresponds to the entry for the key [nil : list bool],
 * the left subtree contains entries for those keys that
 * begin with [true], and the right subtree contains entries
 * for those keys that begin with [false].
 *)

Definition binary_trie A := tree (option A).

(* Here, again, is the module type setting out exactly which theorems you need
 * to prove for full credit on this assignment. *)
Module Type S.

  (* If we [either] an [option] value with [None]
   * on the right, it leaves that value unchanged,
   * (just as if we put the [None] on the left).
   * This is analogous to how appending [nil]
   * on either side of a list leaves it unchanged.
   *)
  Axiom either_None_right : forall {A} (xo : option A),
    either xo None = xo.

  (* [either] is associative, just like [++].
   *)
  Axiom either_assoc : forall {A} (xo yo zo : option A),
    either (either xo yo) zo = either xo (either yo zo).

  (* [head] should compute the head of a list, that is,
   * it should return [Some] with the first element of
   * the list if the list is nonempty, and [None]
   * if the list is empty.
   *)
  Parameter head : forall {A}, list A -> option A.

  Axiom head_example : head [1; 2; 3] = Some 1.

  (* The following theorem makes a formal connection
   * between [either] and [++].
   *)
  Axiom either_app_head : forall {A} (xs ys : list A),
      head (xs ++ ys) = either (head xs) (head ys).

  (* [leftmost_Node] should compute the leftmost node of
   * a tree.
   *
   * Please implement [leftmost_Node] directly using
   * recursion (i.e., pattern matching) on the [tree] argument,
   * without using the [flatten] operation.
   *)
  Parameter leftmost_Node : forall {A}, tree A -> option A.

  Axiom leftmost_Node_example :
    leftmost_Node (Node (Node Leaf 2 (Node Leaf 3 Leaf)) 1 Leaf)
    = Some 2.

  (* Prove that the leftmost node of the tree is the same
   * as the head of the list produced by flattening the tree
   * with an in-order traversal.
   *)
  Axiom leftmost_Node_head : forall {A} (t : tree A),
      leftmost_Node t = head (flatten t).

  (* Now let's work with the binary tries we defined earlier!
   *
   * Define [lookup] such that [lookup k t] looks up the
   * map entry corresponding to the key [k : list bool] in the
   * binary trie [t : binary_trie A], interpreting [t] such that
   * the value at the root of [t] corresponds to the
   * entry for the key [nil], the left subtree contains entries
   * for those keys that begin with [true], and the right subtree
   * contains entries for those keys that begin with [false].
   *)
  Parameter lookup : forall {A}, list bool -> binary_trie A -> option A.

  Axiom lookup_example1 : lookup [] (Node Leaf (None : option nat) Leaf) = None.

  Axiom lookup_example2 : lookup [false; true]
    (Node (Node Leaf (Some 2) Leaf) None (Node (Node Leaf (Some 1) Leaf) (Some 3) Leaf))
                          = Some 1.

  (* [Leaf] represents an empty binary trie, so a lookup for
   * any key should return [None].
   *)
  Axiom lookup_empty : forall {A} (k : list bool),
      lookup k (Leaf : binary_trie A) = None.

  (* Define an operation to "insert" a key and optional value
   * into a binary trie. The [insert] definition should satisfy two
   * properties: one is [lookup_insert] below, which says that if we
   * look up a key [k] in a trie where [(k, v)] has just been inserted,
   * the result should be [v]. The other is that lookups on keys different
   * from the one just inserted should be the same as on the original map.
   *
   * If an entry for that key already exists, [insert] should replace
   * that entry with the new one being inserted. Note that [insert] can
   * be used to remove an entry from the trie, too, by inserting [None]
   * as the value.
   *
   * Hint: it may be helpful to define an auxiliary function that inserts
   * a key and optional value into the empty trie.
   *)
  Parameter insert : forall {A}, list bool -> option A -> binary_trie A -> binary_trie A.

  Axiom insert_example1 : lookup [] (insert [] None (Node Leaf (Some 0) Leaf)) = None.
  Axiom insert_example2 : lookup [] (insert [true] (Some 2) (Node Leaf (Some 0) Leaf)) = Some 0.

  Axiom lookup_insert : forall {A} (k : list bool) (v : option A) (t : binary_trie A),
      lookup k (insert k v t) = v.
End S.

(* The template file Pset2.v also suggests an additional challenge problem,
 * which won't be graded, but which provides extra practice with container data
 * structures.  The key operation is *left-biased merge for trees*. *)


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute next_weekday monday.

Example test_next_weekday:
  next_weekday (next_weekday saturday) = tuesday.
Proof. simpl. reflexivity. Qed.


Require Import Coqlib.
Require Import RelationPairs.
Require Import AST.
Require Import Decision.
Require Import Structures.
Require Import PseudoJoin.

Module PJR.

  (** * Syntax *)

  Section SYNTAX.
    Inductive term :=
      | empty: term
      | var: nat -> term
      | combine: term -> term -> term.

    (** Normalization *)

    Fixpoint insert (i: nat) (t: term): term :=
      match t with
        | combine (var j) u =>
          if decide (i <= j)%nat then
            combine (var i) (combine (var j) u)
          else
            combine (var j) (insert i u)
        | _ =>
          combine (var i) t
      end.

    Fixpoint insert_term (t u: term): term :=
      match t with
        | empty => u
        | var i => insert i u
        | combine t1 t2 => insert_term t1 (insert_term t2 u)
      end.

    Definition sort (t: term) :=
      insert_term t empty.
  End SYNTAX.

  (** * Semantics *)

  Section SEMANTICS.
    Context {E} `{Ee: Emptyset E} `{HE: PseudoJoin E ∅}.
    Local Opaque equiv.

    Fixpoint lookup (i: nat) (env: list E) :=
      match i, env with
        | O, x::xs => x
        | S j, x::xs => lookup j xs
        | _, _ => ∅
      end.

    Fixpoint eval (env: list E) (t: term): E :=
      match t with
        | empty => ∅
        | var i => lookup i env
        | combine t1 t2 => eval env t1 ⊕ eval env t2
      end.

    Lemma insert_sound env i t:
      eval env (insert i t) ≡ eval env (combine (var i) t).
    Proof.
      simpl.
      induction t; try reflexivity.
      - simpl.
        destruct t1 as [ | j | u1 u2]; simpl; try reflexivity.
        destruct (decide _); simpl; try reflexivity.
        rewrite IHt2.
        rewrite <- !associativity.
        rewrite (commutativity (lookup _ _)).
        reflexivity.
    Qed.

    Lemma insert_term_sound env t u:
      eval env (insert_term t u) ≡ eval env (combine t u).
    Proof.
      revert u.
      induction t as [ | i | t1 IHt1 t2 IHt2 ]; intro u.
      - simpl.
        split.
        + apply right_upper_bound.
        + apply id_left.
      - transitivity (eval env (insert i u)).
        + reflexivity.
        + apply insert_sound.
      - simpl.
        rewrite IHt1; simpl.
        rewrite IHt2; simpl.
        symmetry.
        apply associativity.
    Qed.

    Lemma sort_sound env t:
      eval env (sort t) ≡ eval env t.
    Proof.
      unfold sort.
      transitivity (eval env (combine t empty)).
      - apply insert_term_sound.
      - simpl.
        split.
        + apply id_right.
        + apply left_upper_bound.
    Qed.
  End SEMANTICS.

  (** * Verification conditions *)

  Section VERIF.
    Context {E} `{Ee: Emptyset E} `{HE: PseudoJoin E ∅}.

    (** Sufficient check for 〚t〛 ≤ 〚u〛. Works on terms n normalize
      by [sort] above. *)
    Fixpoint termcmp (t u: term): bool :=
      match t, u with
        | empty, _ =>
          true
        | combine (var i) t', combine (var j) u' =>
          if decide (i = j) then
            termcmp t' u'
          else
            termcmp t u'
        | _, _ =>
          false
      end.

    Lemma termcmp_sound env t u:
      termcmp t u = true ->
      eval env t ≤ eval env u.
    Proof.
      revert t.
      induction u as [ | i | [ | i | u11 u12] IHu1 u2 IHu2];
        intros t;
        destruct t as [ | j | [ | j | t11 t12] t2];
        inversion 1;
        try apply lower_bound.
      destruct (decide _); subst.
      - simpl.
        monotonicity.
        + reflexivity.
        + eauto.
      - transitivity (eval env u2).
        + eauto.
        + simpl.
          apply right_upper_bound.
    Qed.

    Lemma termcmp_sort_sound env t u:
      termcmp (sort t) (sort u) = true ->
      eval env t ≤ eval env u.
    Proof.
      intros H.
      rewrite <- (sort_sound env t).
      rewrite <- (sort_sound env u).
      apply termcmp_sound.
      assumption.
    Qed.
  End VERIF.

  (** Lookup [x] in list [env]. If it's not in there, a corresponding
    element is added at the end of the list. Then pass the potentially
    extended environment and index to the continuation [cont]. *)
  Ltac l env x cont :=
    let rec iter i e :=
      lazymatch e with
        | x::?xs => cont env i
        | _::?xs => iter (S i) xs
        | _ =>
          let newenv := eval cbv [app] in (env++(x::nil)) in
          cont newenv i
      end in
    iter O env.

  (** Quote the pseudo-join expression [x] with the starting
    environment [env] for variables. The extended environment and
    quoted term are then passed to the continuation [cont]. *)
  Ltac q env x cont :=
    lazymatch x with
      | ∅ => cont env empty
      | ?x1 ⊕ ?x2 =>
        let cont1 env1 t1 :=
          let cont2 env2 t2 :=
            cont env2 (combine t1 t2) in
          q env1 x2 cont2 in
        q env x1 cont1
      | _ =>
        let lcont env i := cont env (var i) in
        l env x lcont
    end.

  Ltac quoteineq :=
    lazymatch goal with
      | |- le (A := ?E) ?x ?y =>
        let xcont xenv t :=
          let ycont yenv u :=
            (change (eval yenv t ≤ eval yenv u)) in
          q xenv y ycont in
        q (@nil E) x xcont
    end.
End PJR.

Ltac pjr :=
  PJR.quoteineq;
  eapply PJR.termcmp_sort_sound;
  reflexivity.

Section TEST.
  Context {E} `{Ee: Emptyset E} `{HE: PseudoJoin E ∅}.
  Context {a b c d e: E}.

  Goal a ⊕ ∅ ⊕ d ≤ b ⊕ e ⊕ d ⊕ a ⊕ b.
  Proof.
    pjr.
  Qed.
End TEST.


From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype path
  ssrint rat bigop.

From extructures Require Import ord fset fmap ffun.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope fset_scope.

Definition int_ordMixin := CanOrdMixin natsum_of_intK.
Canonical int_ordType := Eval hnf in OrdType int int_ordMixin.

Definition rat_ordMixin := [ordMixin of rat by <:].
Canonical rat_ordType := Eval hnf in OrdType rat rat_ordMixin.

Section Update.

Context {T : ordType} {S : eqType} {def : T -> S}.

Definition updm (f : ffun def) (xs : {fmap T -> S}) : ffun def :=
  mkffun (fun v => if xs v is Some x then x else f v)
         (supp f :|: domm xs).

Lemma updmE f xs x :
  updm f xs x = if xs x is Some y then y else f x.
Proof.
rewrite /updm mkffunE in_fsetU orbC mem_domm.
case e: (xs x)=> [y|] //=.
by case: ifPn=> // /suppPn ->.
Qed.

End Update.

Arguments bigcupP {_ _ _ _ _ _}.
Arguments mkfmap {_ _}.


Definition N := 23.

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

Fixpoint binary_tree c n :=
  match n with
  | 0 => Leaf
  | S n =>
    let t := binary_tree c n in
    Node c t t
  end.

Definition t0 := Eval vm_compute in binary_tree 0 N.
Definition t1 := Eval vm_compute in binary_tree 1 N.


(* Implementation of the compiler (both tree-based and graph-based
variant) and proof of Lemma 1 from the paper (compT e = unravel (compG
e).  *)

Require Import Graph.
Require Import Tree.
Require Import GraphUnravel.
Require Import Coq.Program.Basics.
Require Import CalculationTactics.

Require Import Coq.Logic.FunctionalExtensionality.

(* Source language. *)

Inductive Expr : Set :=
  | Val : nat -> Expr
  | Add : Expr -> Expr -> Expr
  | Throw  : Expr
  | Catch : Expr -> Expr -> Expr.

(* For the definition of the source language we have to use containers
in order to instantiate the definition of trees and graphs (which use
containers to represent strictly positive functors). *)

(* The shape type. *)

Inductive CodeSh : Set :=
| PUSH : nat -> CodeSh
| ADD : CodeSh
| THROW : CodeSh
| MARK : CodeSh
| UNMARK : CodeSh
| HALT : CodeSh.

(* Definition of the container to represent the functor [Code] from
the paper. *)

Definition Code : Cont :=
  {| shapes := CodeSh;
    pos := fun s => match s with
                      | PUSH _ => unit
                      | ADD => unit
                      | THROW => Zero
                      | MARK => sum unit unit
                      | UNMARK => unit
                      | HALT => Zero
                    end
   |}.

(* Functions to define unary and binary constructors (of the functor). *)
Definition one {A} (a : A) (x : unit) : A := a.
Definition two {A} (a b : A) (x : sum unit unit) : A :=
  match x with
            | inl _  => a
            | inr _ => b
  end.

(* Definition of the constructors for the [Code] functor. *)
Definition mkPUSH {A} i (c : A) : Ext Code A := (ext Code (PUSH i) (one c)).
Definition mkADD {A} (c : A) : Ext Code A := (ext Code ADD (one c)).
Definition mkTHROW {A} : Ext Code A := (ext Code THROW (zero _)).
Definition mkMARK {A} (c c' : A) : Ext Code A := (ext Code MARK (two c c')).
Definition mkUNMARK {A} (c : A) : Ext Code A := (ext Code UNMARK (one c)).
Definition mkHALT {A}  : Ext Code A := (ext Code HALT (zero _)).

(* Graph variants of the constructors. *)
Import Graph.
Definition gPUSH {A} i c : GraphM Code A := In (mkPUSH i c).
Definition gADD {A} c : GraphM Code A := In (mkADD c).
Definition gTHROW {A} : GraphM Code A := In mkTHROW.
Definition gMARK {A} c c' : GraphM Code A := In (mkMARK c c').
Definition gUNMARK {A} c : GraphM Code A := In (mkUNMARK c).
Definition gHALT {A} : GraphM Code A := In mkHALT.

(* Tree variants of the constructors. *)
Import Tree.
Definition tPUSH i c : Tree Code := In (mkPUSH i c).
Definition tADD c : Tree Code := In (mkADD c).
Definition tTHROW : Tree Code := In mkTHROW.
Definition tMARK c c' : Tree Code := In (mkMARK c c').
Definition tUNMARK c : Tree Code := In (mkUNMARK c).
Definition tHALT : Tree Code := In mkHALT.

Infix "|>" := (apply) (at level 60, right associativity).

(* Definition of the graph-based compiler. *)
Fixpoint compG' {A} (e : Expr) (c : GraphM Code A) : GraphM Code A :=
  match e with
      | Val n =>  gPUSH n |> c
      | Add x y =>  compG' x |> compG' y |> gADD |> c
      | Throw =>  gTHROW
      | Catch x h => letx c (fun _ c' =>
                               gMARK (compG' h |> var c') (compG' x |> gUNMARK |> var c'))
  end.

Definition compG (e : Expr) : Graph Code := compG' e |> gHALT.

(* Definition of the tree-based compiler. *)
Fixpoint compT' (e : Expr) (c : Tree Code) : Tree Code :=
  match e with
      | Val n =>  tPUSH n |> c
      | Add x y =>  compT' x |> compT' y |> tADD |> c
      | Throw =>  tTHROW
      | Catch x h => tMARK (compT' h |> c) (compT' x |> tUNMARK |> c)
  end.

Definition compT (e : Expr) : Tree Code := compT' e |> tHALT.

(* Convenience lemmas that state how unravelling works on the
constructors. *)

Lemma unravelM_mark {A env} {c1 c2 : GraphM Code A} :
  unravelM env (gMARK c1 c2) = tMARK (unravelM env c1) (unravelM env c2).
Proof.
  unfold unravelM, ufoldM, tMARK, gMARK, mkMARK. simpl. unfold cmap, two. simpl. repeat f_equal.
  apply functional_extensionality. intros. destruct x; reflexivity.
Qed.

Lemma unravelM_throw {A} {env : Env _ A} :  unravelM env gTHROW = tTHROW.
Proof.
  unfold gTHROW, tTHROW, mkTHROW, unravelM, ufoldM.  simpl. unfold cmap. simpl. repeat f_equal.
  apply zero_unique.
Qed.

Lemma unravelM_halt {A} {env : Env _ A} :  unravelM env gHALT = tHALT.
Proof.
  unfold gHALT, tHALT, mkHALT, unravelM, ufoldM.  simpl. unfold cmap. simpl. repeat f_equal.
  apply zero_unique.
Qed.

(* Proof of Lemma 1 from the paper. The following is the main lemma
for the proof, which corresponds to the induction proof from the
paper. *)

Lemma comp_unravelM {A} {e : Expr} {env} {c : GraphM Code A} : compT' e (unravelM env c)
                                                              = unravelM env (compG' e c).
Proof.   Begin.
  unfold compT, unravel, compG, apply.

  generalize dependent A.  induction e; intros; simpl; unfold apply.

  reflexivity.

  rewrite <- IHe1.  rewrite <- IHe2. reflexivity.

  rewrite unravelM_throw. reflexivity.

  RHS
  = { rewrite unravelM_letx }
  (unravelM (Extend (unravelM env c) env)
            (gMARK (compG' e2 (var tt)) (compG' e1 (gUNMARK (var tt))))).
  = { rewrite unravelM_mark }
  (tMARK ( unravelM (Extend (unravelM env c) env) (compG' e2 (var tt)))
         ( unravelM (Extend (unravelM env c) env) (compG' e1 (gUNMARK (var tt))))).
  = { rewrite IHe1 }
      (tMARK ( unravelM (Extend (unravelM env c) env) (compG' e2 (var tt)))
             ( compT' e1 (unravelM (Extend (unravelM env c) env) (gUNMARK (var tt))))).
  = { rewrite IHe2 }
      (tMARK ( compT' e2 (unravelM (Extend (unravelM env c) env)(var tt)))
             ( compT' e1 (unravelM (Extend (unravelM env c) env) (gUNMARK (var tt))))).
  = { reflexivity }
      (tMARK ( compT' e2 (unravelM env c))
             ( compT' e1 (tUNMARK (unravelM env c)))).
  [].
Qed.

(* From the above lemma we can then derive Lemma 1. *)

Lemma comp_unravel {e : Expr} : compT e = unravel (compG e).
Proof.
  unfold compT, compG, apply, unravel. erewrite <- unravelM_halt. eapply comp_unravelM.
Qed.


(******************************************************************************)
(* Chapter 1.5: Isomorphisms                                                  *)
(******************************************************************************)

(*
(0)
同じディレクトリにある Categories.v と Functor.v を使う。

(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Morphisms.                   (* coq standard libs. *)
Require Import Notations.                   (* same dir. *)
Require Import Categories.                  (* same dir. *)
Require Import Functors.                    (* same dir. *)

(* 圏Cにおいて、同型射 f : a ~> b が存在するとき、a と b は同型である。 *)
(* 同型射とは、g \\o f === id かつ f \\o g === id なる f *)
Class Isomorphism `{C : Category} {a b : C} (f : a ~> b) (g : b ~> a) : Prop :=
  {
    iso_cmp1  : g \\o f === id;             (* id a *)
    iso_cmp2  : f \\o g === id              (* id b *)
  }.
(* TO DO: show isos are unique when they exist *)

(* f と g をメンバで定義した版 *)
Class Isomorphic `{C : Category} (a b : C) :=
  {
    iso_forward  :  a ~> b;
    iso_backward :  b ~> a;
    iso_comp1    :  iso_backward \\o iso_forward === id; (* id a *)
    iso_comp2    :  iso_forward \\o iso_backward === id  (* id b *)
(* TO DO: merge this with Isomorphism *)
}.
(* 同型射 f は、ひとつの同型(な関係にあるaとb)を与えないと決まらない。
   Isomorphic a b をexplicitに与えるようにする。 *)
Check @iso_forward : ∀Obj Hom C a b _, a ~> b.
Check iso_forward : _ ~> _.
Arguments iso_forward  {Obj Hom C a b} i : rename.
Arguments iso_backward {Obj Hom C a b} i : rename.
Arguments iso_comp1    {Obj Hom C a b} i : rename.
Arguments iso_comp2    {Obj Hom C a b} i : rename.
Check iso_forward _ : _ ~> _.                 (* 最初の _ は、Isomorphic a b *)
Check iso_forward : Isomorphic _ _ -> _ ~> _. (* _ は、圏Cの対象 a b *)

Notation "a ≅ b" := (Isomorphic a b) : isomorphism_scope.
(* the sharp symbol "casts" an isomorphism to the morphism in the forward direction *)
Notation "# f" := (iso_forward f) : isomorphism_scope.
Open Scope isomorphism_scope.

(* 同型a,bに対して、同型b,aを求めることができる。 *)
(* aに対してbが同型なら、bに対してaも同型である。 *)
(* the inverse of an isomorphism is an isomorphism *)
Definition iso_inv `{C : Category} (a b : C) (iso : Isomorphic a b) : Isomorphic b a.
Proof.
  Check iso_backward.
  Check @Build_Isomorphic _ _ _ _ _ (iso_backward iso) (iso_forward iso).
  apply (@Build_Isomorphic _ _ _ _ _ (iso_backward iso) (iso_forward iso)).
  - by apply iso_comp2.
  - by apply iso_comp1.
Defined.
Check @iso_inv : ∀Obj Hom C a b _, b ≅ a.
Arguments iso_inv {Obj Hom C a b} f : rename.
Check iso_inv _ : _ ≅ _.                    (* 最初の _ は a ≅ b *)
Check iso_inv : _ ≅ _ -> _ ≅ _.             (* _ は、圏Cの対象 a b *)
Notation "f '⁻¹'" := (iso_inv f) : isomorphism_scope.

(* 同型a,a *)
(* aとaは同型である。 *)
(* identity maps are isomorphisms *)
Definition iso_id `{C : Category} (a : C) : Isomorphic a a.
Proof.
  Check @Build_Isomorphic _ _ C a a id id.
  apply (@Build_Isomorphic _ _ C a a id id).
  now rewrite left_identity.
  now rewrite left_identity.
Defined.
Check @iso_id.
Arguments iso_id {Obj Hom C a} : rename.
Check iso_id : _ ≅ _.                       (* _ は、圏Cの対象a *)

(* 同型a,b と 同型b,c なら、同型a,c *)
(* the composition of two isomorphisms is an isomorphism *)
Definition iso_comp `{C : Category} {a b c : C}
           (i1 : Isomorphic a b) (i2 : Isomorphic b c) : Isomorphic a c.
Proof.
  Check #i1 : a ~> b.                       (* iso_forward i1 *)
  Check #i2 : b ~> c.                       (* iso_forward i2 *)
  Check #i2 \\o #i1 : a ~> c.
  Check #i1⁻¹ : b ~> a.                     (* iso_inv (iso_forward i1) *)
  Check #i2⁻¹ : c ~> b.                     (* iso_inv (iso_forward i2) *)
  Check iso_comp1 i1 : iso_backward i1 \\o #i1 === id.
  Check iso_comp2 i1 : #i1 \\o iso_backward i1 === id.
  Check iso_comp1 i2 : iso_backward i2 \\o #i2 === id.
  Check iso_comp2 i2 : #i2 \\o iso_backward i2 === id.

  Check (@Build_Isomorphic _ _ C a c (#i2 \\o #i1) (#i1⁻¹ \\o #i2⁻¹)).
  apply (@Build_Isomorphic _ _ C a c (#i2 \\o #i1) (#i1⁻¹ \\o #i2⁻¹)).
  - rewrite juggle3 (iso_comp1 i2).
    rewrite associativity left_identity (iso_comp1 i1).
    reflexivity.
  - rewrite juggle3 (iso_comp2 i1).
    rewrite associativity left_identity (iso_comp2 i2).
    reflexivity.
Defined.
Check @iso_comp : ∀Obj Hom C a b c _ _, a ≅ c.
Check iso_comp _ _ : _ ≅ _.
Arguments iso_comp {Obj Hom C} a b c i1 i2 : rename.
Check iso_comp : ∀a b c _ _, a ≅ c.
Notation "a >>≅>> b" := (iso_comp a b).

(* 関手は同型を保存する。 *)
Definition functors_preserve_isos `{C1 : Category} `{C2 : Category} {Fo : C1 -> C2}
           (F : Functor Fo) {a b : C1} (i : Isomorphic a b) : Isomorphic (F a) (F b).
Proof.
  (* 圏C1を関手で写した先の圏C2、C2の同型を作る。 *)
  Check F \ (iso_forward i) : F a ~> F b.
  Check F \ #i : F a ~> F b.
  Check F \ (iso_backward i) : F b ~> F a.
  Check {| iso_forward  := F \ (iso_forward  i);
           iso_backward := F \ (iso_backward i)
        |}.
  Check (@Build_Isomorphic).
  Check (@Build_Isomorphic Obj0 Hom0 C2 (F a) (F b)
                           (F \ (# i))
                           (F \ (iso_backward i))).
  Check (@Build_Isomorphic _ _ _ (F a) (F b)
                           (F \ (# i))
                           (F \ (iso_backward i))).
  (* Standard Coq の refine は、SSReflect の apply: である。 *)
  refine {| iso_forward  := F \ (iso_forward  i);
            iso_backward := F \ (iso_backward i)
         |}.
  Undo 1.
  apply: {| iso_forward  := F \ (iso_forward  i);
            iso_backward := F \ (iso_backward i)
         |}.
  Undo 1.
  apply (@Build_Isomorphic _ _ _ _ _
                           (F \ (# i))
                           (F \ (iso_backward i))).
  (* F \ iso_backward i \\o F \ #i === id *)
  - rewrite fmor_preserves_comp.
    rewrite iso_comp1.
    apply fmor_preserves_id.
  (* F \ #i \\o F \ iso_backward i === id *)
  - rewrite fmor_preserves_comp.
    rewrite iso_comp2.
    apply fmor_preserves_id.
Defined.

(* 圏Cの対象b,aが同型である（同型射 b ~> c がある）とき、
   圏Cの射f : b ~> c と、射g : a ~> c の関係を示す。
 *)
Lemma iso_shift_right `{C : Category} {a b c : C}
      (f : b ~> c) (g : a ~> c) (i : Isomorphic b a) :
  f \\o #i⁻¹ === g -> f === g \\o #i.
Proof.
  move=> H.
  rewrite -H associativity iso_comp1 right_identity.
  reflexivity.
Qed.

Lemma iso_shift_right' `{C : Category} {a b c : C}
      (f : b ~> c) (g : a ~> c) (i : Isomorphic a b) :
  f \\o #i === g -> f === g \\o #i⁻¹.
Proof.
  move=> H.
  rewrite -H.
  rewrite associativity.                    (* assoc の定義がオリジナルと異なる。 *)
  rewrite iso_comp2 right_identity.         (* あとは、少し証明が変わる。 *)
  reflexivity.
Qed.

Lemma iso_shift_left `{C : Category} {a b c : C}
      (f : a ~> b) (g : a ~> c) (i : Isomorphic c b) :
  #i⁻¹ \\o f === g -> f === #i \\o g.
Proof.
  move=> H.
  rewrite -H -associativity iso_comp2 left_identity.
  reflexivity.
Qed.

Lemma iso_shift_left' `{C : Category} {a b c : C}
      (f : a ~> b) (g : a ~> c) (i : Isomorphic b c) :
  #i \\o f === g -> f === #i⁻¹ \\o g.
Proof.
  move=> H.
  rewrite -H -associativity iso_comp1 left_identity.
  reflexivity.
Qed.

(* 圏Cの対象aとbに対して、a,bの同型（同型射 a ~> b）が同じなら、
b,aの同型（同型射 b ~> a）も同じである。 *)
Lemma isos_forward_equal_then_backward_equal `{C : Category} {a b : C}
      (i1 i2 : Isomorphic a b)  :  #i1 === #i2 ->  #i1⁻¹ === #i2⁻¹.
Proof.
  move=> H.
  rewrite -[#i1 ⁻¹]left_identity.
  rewrite -(iso_comp1 i2).
  rewrite associativity.
  rewrite -H.
  rewrite (iso_comp2 i1).
  rewrite right_identity.
  rewrite /=.
  reflexivity.
Qed.

(* 圏Cの対象aとbに対して、a,bの同型（同型射 a ~> b）の逆の逆は同じ *)
Lemma iso_inv_inv `{C : Category} {a b : C} (i : Isomorphic a b) :
  #(i⁻¹)⁻¹ === #i.
Proof.
  rewrite /iso_inv /=.
  reflexivity.
Qed.

(* the next four lemmas are handy for setoid_rewrite; they let you
avoid having to get the associativities right *)

Lemma iso_comp2_right  `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : b ~> c) :
  g \\o iso_forward i \\o iso_backward i === g.
Proof.
  rewrite associativity.
  rewrite iso_comp2.
  rewrite right_identity.
  reflexivity.
Qed.

Lemma iso_comp2_left `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : c ~> b) :
  iso_forward i \\o (iso_backward i \\o g)  === g.
Proof.
  rewrite -associativity.
  rewrite iso_comp2.
  rewrite left_identity.
  reflexivity.
Qed.

Lemma iso_comp1_right `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : a ~> c) :
  g \\o iso_backward i \\o iso_forward i === g.
Proof.
  rewrite associativity.
  rewrite iso_comp1.
  rewrite right_identity.
  reflexivity.
Qed.

Lemma iso_comp1_left `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : c ~> a) :
  iso_backward i \\o (iso_forward i \\o g)  === g.
Proof.
  rewrite -associativity.
  rewrite iso_comp1.
  rewrite left_identity.
  reflexivity.
Qed.

(* END *)


Set Implicit Arguments.
Require Import FinFun.
From Undecidability.HOU Require Import std.decidable.

Inductive diag: nat -> nat -> Type :=
  | diagB: diag 0 0
  | diagC: forall m, diag 0 m -> diag (S m) 0
  | diagS: forall n m, diag (S n) m -> diag n (S m).

Fixpoint diagStepR m n (d: diag m n) : diag m (S n) :=
  match d with
  | diagB => diagS (diagC diagB)
  | diagC H => diagS (diagC (diagStepR H))
  | diagS H => diagS (diagStepR H)
  end.

Fixpoint diagStepL m n (d: diag m n) : diag (S m) n :=
  match d with
  | diagB => diagC diagB
  | diagC H => diagC (diagS (diagStepL H))
  | diagS H => diagS (diagStepL H)
  end.

Fixpoint diagZero (a: nat) : diag 0 a :=
  match a with
  | 0 => diagB
  | S a => diagStepR (diagZero a)
  end.

Fixpoint diagId m n: diag m n :=
  match m with
  | O => diagZero n
  | S m => diagStepL (diagId m n)
  end.

Definition I__P (p: nat * nat) :=
  let (m, n) := p in
  diag_rect (fun _ _ _ => nat) 0 (fun _ _ => S)  (fun _ _ _ => S) (diagId m n): nat.

Fixpoint R__P (n: nat) : nat * nat  :=
  match n with
    | 0 =>  (0,0)
    | S n => match R__P n with
            | (0, b)  => (S b, 0)
            | (S a, b) => (a, S b)
      end
   end.

Lemma R__P_I__P p: R__P (I__P p) = p.
Proof.
  unfold I__P; destruct p as [m n]; induction (diagId m n); cbn.
  - reflexivity.
  - now rewrite IHd.
  - now rewrite IHd.
Qed.

Lemma R__P_injective n m: R__P n = R__P m -> n = m.
Proof.
  induction n in m |-*; destruct m; cbn; eauto.
  1: destruct (R__P m) as [[] b]; discriminate.
  1: destruct (R__P n) as [[] b]; discriminate.
  destruct (R__P n) as [[|k] p] eqn: H1, (R__P m) as [[|k'] p'] eqn: H2.
  all: injection 1; intros; subst.
  all: erewrite IHn; eauto.
  all: discriminate.
Qed.

Lemma I__P_R__P n: I__P (R__P n) = n.
Proof.
  eapply R__P_injective; now rewrite R__P_I__P.
Qed.

Require Import Arith Lia Nat Arith.Div2.

Definition I__S (s: nat + nat) :=
  match s with
  | inl n => double n
  | inr n => S (double n)
  end.

Definition R__S (n: nat) :=
  if even n then inl (div2 n) else inr (div2 n).

Lemma I__S_R__S n: I__S (R__S n) = n.
Proof.
  unfold I__S, R__S.
  destruct Nat.even eqn: H1.
  - symmetry. eapply even_double.
    now eapply Even.even_equiv, Nat.even_spec.
  - symmetry. eapply odd_double; eauto.
    eapply Even.odd_equiv, Nat.odd_spec.
    unfold odd; rewrite H1; eauto.
Qed.

Lemma R__S_I__S s: (R__S (I__S s)) = s.
Proof.
  unfold I__S, R__S.
  destruct s.
  - specialize (Nat.even_spec (Nat.double n)) as [_ H].
    rewrite H, Nat.double_twice, Nat.div2_double; eauto.
    eapply Nat.even_spec.
    unfold Nat.double.
    rewrite Nat.even_add.
    destruct (Nat.even n); reflexivity.
  - specialize (Nat.even_spec (Nat.double n)) as [_ H].
    rewrite Nat.even_succ, <-Nat.negb_even.
    rewrite H; cbn [negb].
    rewrite Nat.double_twice, Nat.div2_succ_double; eauto.
    eapply Nat.even_spec; unfold Nat.double;
      rewrite ?Nat.even_add; destruct (Nat.even n); reflexivity.
Qed.

Lemma injective_I__S : Injective I__S.
Proof.
  intros s s' H % (f_equal R__S). now rewrite !R__S_I__S in H.
Qed.

Lemma injective_I__P : Injective I__P.
Proof.
  intros s s' H % (f_equal R__P). now rewrite !R__P_I__P in H.
Qed.

Arguments I__P p : simpl never.
Arguments R__P n : simpl never.
Arguments I__S s : simpl never.
Arguments R__S n : simpl never.