Inductive foo := C1 : bar -> foo with bar := C2 : foo -> bar.

Lemma L1 : foo -> True with L2 : bar -> True.
intros; clear L1 L2; abstract (exact I).
intros; exact I.
Qed.


(* Alternate verification of main.c using user_specs, the normal
malloc/free specs without resource tracking.
By contrast, verif_main.c uses the resource-tracking specs,
which is needed as of Feb 2020 to prove (in link_main.v) correctness
of the linked program, owing to limitations of the linking tactics.
*)

Require Import VST.floyd.proofauto.
Require Import linking.
Require Import malloc.
Require Import main.
Require Import malloc_lemmas.
Require Import spec_malloc.
Require Import spec_main.

Definition Gprog : funspecs := spec_main.specs ++ user_specs.

Definition Vprog : varspecs. mk_varspecs linked_prog. Defined.

Lemma body_main_alt: semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv); auto.
forward_call(100,gv). (* t1 = malloc(100) *)
rep_omega.
Intros p.
if_tac.
+ (* p = nullval *)
 subst p.
 forward_call (100,nullval,gv).  (* free (p); *)
 entailer!.
 forward. (* return *)
+
 forward_call (100,p,gv).  (* free (p); *)
 rewrite if_false by auto. cancel.
 forward. (* return *)
Qed.


Require extraction.ExtrOcamlString.

Require Import MicroPolicies.Printer.
Require Import Tests.I2MP.MP_RSC_Test.

From Coq Require Extraction.

Require Import Common.Definitions.
Require Import Common.Values.
From mathcomp Require Import ssrfun seq ssrint ssrnat.
Require Import Arith ZArith.
Require Import Coq.extraction.ExtrOcamlBasic.
Require Import Coq.extraction.ExtrOcamlNatBigInt.
Require Import Coq.extraction.ExtrOcamlZBigInt.
Require Import Coq.extraction.ExtrOcamlBigIntConv.
Require Export Extraction.
Require Import Coq.Strings.String.

(* NOTE: add the following two lines at the start of the extracted file:
#load "nums.cma";;
open Big_int;;
 *)

Axiom fstate : Type.
Extract Constant fstate => "unit".
Extraction Inline fstate.
Axiom fstate0 : fstate.
Extract Constant fstate0 => "()".
Extraction Inline fstate0.

Axiom unit_to_fstate : unit -> fstate.
Extract Constant unit_to_fstate => "".
Extraction Inline unit_to_fstate.
Axiom fstate_to_unit : fstate -> unit.
Extract Constant fstate_to_unit => "".
Extraction Inline fstate_to_unit.

Axiom ocaml_int : Type.
Axiom ocaml_int_0 : ocaml_int.
Axiom ocaml_int_1: ocaml_int.
Axiom ocaml_int_2: ocaml_int.
Axiom ocaml_int_plus: ocaml_int -> ocaml_int -> ocaml_int.
Axiom ocaml_int_mul: ocaml_int -> ocaml_int -> ocaml_int.
Axiom ocaml_int_neg: ocaml_int -> ocaml_int.

Axiom print_ocaml_int: ocaml_int -> unit.

Axiom print_explicit_exit: unit -> unit.
Axiom print_error: ocaml_int -> unit.
Axiom print_string_error : string -> unit.

Fixpoint pos2int (val: positive) : ocaml_int :=
  match val with
  | xH => ocaml_int_1
  | xI p => ocaml_int_plus (ocaml_int_mul ocaml_int_2 (pos2int p)) ocaml_int_1
  | xO p => ocaml_int_mul ocaml_int_2 (pos2int p)
  end.

Fixpoint z2int (val: Z) : ocaml_int :=
  match val with
  | Z0 => ocaml_int_0
  | Zpos p => pos2int p
  | Zneg p => ocaml_int_neg (pos2int p)
  end.

Fixpoint nat2int (val : nat) : ocaml_int :=
  match val with
  | O => ocaml_int_0
  | S n => ocaml_int_plus (nat2int n) (ocaml_int_1)
  end.

Definition int2int (val : ssrint.int) : ocaml_int :=
  match val with
  | Posz n => (nat2int n)
  | Negz n => ocaml_int_neg (nat2int n)
  end.

Extraction Language Ocaml.

Extract Inductive unit => "unit" [ "()" ].

Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive sumbool => "bool" ["true" "false"].
Extract Constant negb => "not".

Extract Inductive reflect => "bool" ["true" "false"].
Extract Constant introP   => "id".
Extract Constant sumboolP => "fun x -> x".
Extract Constant idP      => "fun x -> x".
Extract Constant idPn     => "not".
Extract Constant negP     => "not".
Extract Constant negPn    => "fun x -> x".
Extract Constant negPf    => "not".
Extract Constant andP     => "(&&)".
Extract Constant and3P    => "fun b1 b2 b3 -> b1 && b2 && b3".
Extract Constant and4P    => "fun b1 b2 b3 b4 -> b1 && b2 && b3 && b4".
Extract Constant and5P    => "fun b1 b2 b3 b4 b5 -> b1 && b2 && b3 && b4 && b5".
Extract Constant orP      => "(||)".
Extract Constant or3P     => "fun b1 b2 b3 -> b1 || b2 || b3".
Extract Constant or4P     => "fun b1 b2 b3 b4 -> b1 || b2 || b3 || b4".
Extract Constant nandP    => "fun b1 b2 -> not (b1 && b2)".
Extract Constant norP     => "fun b1 b2 -> not (b1 || b2)".
Extract Constant addbP    => "(<>)".

Extract Inductive prod => "(*)"  [ "(,)" ].

Extract Inductive list => "list" [ "[]" "(::)" ].

Extract Inductive option => "option" [ "Some" "None" ].

Extract Inductive nat => "Big_int.big_int"
  [ "Big_int.zero_big_int" "Big_int.succ_big_int" ].

Extract Constant ocaml_int => "Big_int.big_int".
Extract Constant ocaml_int_0 => "Big_int.zero_big_int".
Extract Constant ocaml_int_1 => "Big_int.unit_big_int".
Extract Constant ocaml_int_2 => "(Big_int.succ_big_int Big_int.unit_big_int)".
Extract Constant ocaml_int_plus => "Big_int.add_big_int".
Extract Constant ocaml_int_mul => "Big_int.mult_big_int".
Extract Constant ocaml_int_neg => "Big_int.minus_big_int".

Extract Constant print_ocaml_int => "(fun n -> print_string (Big_int.string_of_big_int n); print_newline ())".

Extract Constant print_explicit_exit => "(fun _ -> print_string ""EXIT""; print_newline ())".

Extract Constant print_string_error => "(fun str -> print_string ""FAILED with ""; List.fold_left (fun _ c -> print_char c) () str; print_newline ())".
Extract Constant print_error => "(fun n -> print_string ""FAILED with ""; print_string (Big_int.string_of_big_int n); print_newline ())".

Extract Constant leb    => "Big_int.le_big_int".
Extract Constant Nat.ltb    => "Big_int.lt_big_int".
Extract Constant Nat.max    => "Big_int.max_big_int".
Extract Constant eqb    => "(=)".

(* Extract Constant Nat.eq_dec => "Big_int.eq_big_int". *)
(* Extract Constant Nat.leb    => "Big_int.le_big_int". *)
(* Extract Constant Nat.eqb    => "Big_int.eq_big_int". *)

(* ssr nat *)
Extract Constant ssrnat.eqn             => "Big_int.eq_big_int".
(* Extract Constant ssrnat.addn_rec        => "(+)". *)
(* Extract Constant ssrnat.addn            => "(+)". *)
(* Extract Constant ssrnat.subn_rec        => "(fun x y -> max (x - y) 0)". *)
(* Extract Constant ssrnat.subn            => "(fun x y -> max (x - y) 0)". *)
(* Extract Constant ssrnat.leq             => "(<=)". *)
(* Extract Constant ssrnat.maxn            => "max". *)
(* Extract Constant ssrnat.minn            => "min". *)
(* Extract Constant ssrnat.muln_rec        => "( * )". *)
(* Extract Constant ssrnat.muln            => "( * )". *)
Extract Constant ssrnat.expn_rec        =>
"(fun x y ->
  let rec f acc x n =
  if Big_int.eq_big_int n (Big_int.zero_big_int) then acc
  else f (Big_int.mult_big_int acc x) x (Big.max Big.zero (Big.pred n))
  in
  f (Big_int.succ_big_int Big_int.zero_big_int) x y)".
Extract Constant ssrnat.expn            =>
"(fun x y ->
  let rec f acc x n =
  if Big_int.eq_big_int n (Big_int.zero_big_int) then acc
  else f (Big_int.mult_big_int acc x) x (Big.max Big.zero (Big.pred n))
  in
  f (Big_int.succ_big_int Big_int.zero_big_int) x y)".

(* Extract Constant ssrnat.nat_of_bool     => "(fun b -> if b then 1 else 0)". *)
Extract Constant ssrnat.odd             => "(fun n -> Big_int.eq_big_int
                                                        (Big_int.mod_big_int n
                                                          (Big_int.succ_big_int
                                                             Big_int.unit_big_int))
                                                         Big_int.unit_big_int)".
(* Extract Constant ssrnat.double_rec      => "(fun n -> n * 2)". *)
(* Extract Constant ssrnat.double          => "(fun n -> n * 2)". *)
(* Extract Constant ssrnat.half            => "(fun n -> n / 2)". *)
(* Extract Constant ssrnat.uphalf          => "(fun n -> (n + 1) / 2)". *)
(* ssr div *)
Extract Constant div.edivn    => "fun m d -> if Big.lt Big.zero d then Big_int.quomod_big_int m d else (Big.zero,m)".
Extract Constant div.divn     => "fun m d -> if Big.lt Big.zero d then Big_int.div_big_int m d else Big.zero".
Extract Constant div.modn     => "fun m d -> if Big.lt Big.zero d then Big_int.mod_big_int m d else m".
(* Extract Constant div.gcdn_rec => "Big.gcd". *)
(* Extract Constant div.gcdn     => "Big.gcd". *)
Extract Constant Pos.gcdn     => "Big.gcd".
(* ssr int *)
(* Extract Inductive ssrint.int => int *)
(*                          ["" "(fun n -> - (n+1))"] *)
(*                          "(fun fP fN n -> if n >= 0 then fP n else fN ((abs n) -1))". *)
(* Extract Constant intZmod.addz   => "(+)". *)
(* Extract Constant intZmod.oppz   => "(~-)". *)
(* Extract Constant intRing.mulz   => "( * )". *)
(* Extract Constant absz           => "abs". *)
(* Extract Constant intOrdered.lez => "(<=)". *)
(* Extract Constant intOrdered.ltz => "(<)". *)

(* Provide tail-recursive versions of functions *)
Extract Constant foldr => "
(fun f b l ->
  let rev l =
    let rec revr acc = function
      | [] -> acc
      | hd::tl -> revr (hd::acc) tl
    in
    revr [] l
  in
  let rev_l = rev l
  in
  let rec folder_rr acc = function
    | [] -> acc
    | hd::tl -> folder_rr (f hd acc) tl
  in
  folder_rr b rev_l)".

Extract Constant map =>
"(fun f l ->
  let rev l =
    let rec revr acc = function
    | [] -> acc
    | hd::tl -> revr (hd::acc) tl
    in revr [] l
  in
  let rec mapr acc = function
    | [] -> rev acc
    | x::xs -> mapr ((f x)::acc) xs
  in
  mapr [] l)".

(* Workaround that allows the generated code to be compiled:
see [https://github.com/coq/coq/issues/4875] and [https://github.com/coq/coq/issues/6614] *)
Extraction Inline SimplPred.

Extraction "/tmp/tl_quickchick_test.ml" coqstring_of_state mp_rsc_correct.


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

(****************************************************************************)
(*                          Signes Project                                  *)
(*                            2002-2003                                     *)
(*                           Houda ANOUN                                    *)
(*                          Pierre Casteran                                 *)
(*                           LaBRI/INRIA                                    *)
(****************************************************************************)

Require Export Sequent.
Require Export NaturalDeduction.

Set Implicit Arguments.

(* these definitions will help us to prove that natural deduction is equivalent
to gentzen calculus *)

Definition replaceGentzen :
  forall (Atoms: Set)(Gamma Gamma' Delta Delta' : Term Atoms)
  (E : gentzen_extension),
  replace Gamma Gamma' Delta Delta' ->
  gentzenSequent E Delta' (deltaTranslation Delta) ->
  gentzenSequent E Gamma' (deltaTranslation Gamma).
 simple induction 1.
 auto.
 intros.
 simpl in |- *.
 apply RightDot; auto.
 apply axiomeGeneralisation.
 intros.
 simpl in |- *.
 apply RightDot.
 apply axiomeGeneralisation.
 auto.
Defined.

Definition replaceGentzen' :
  forall (Atoms:Set)(Gamma Gamma' Delta Delta' : Term Atoms)
 (C : Form Atoms) (E : gentzen_extension),
  replace Gamma Gamma' Delta Delta' ->
  gentzenSequent E Delta' (deltaTranslation Delta) ->
  gentzenSequent E Gamma C -> gentzenSequent E Gamma' C.
 intros.
 apply CutRuleSimpl with (deltaTranslation Gamma).
 eapply replaceGentzen; eauto.
 apply TermToForm.
 assumption.
Defined.

Definition replaceNatDed :
  forall (Atoms:Set) (Gamma Gamma' Delta Delta' : Term Atoms)
  (E : gentzen_extension),
  replace Gamma Gamma' Delta Delta' ->
  natDed E Delta' (deltaTranslation Delta) ->
  natDed E Gamma' (deltaTranslation Gamma).
 simple induction 1.
 intros.
 assumption.
 intros.
 simpl in |- *.
 apply DotIntro.
 auto.
 apply axiomGen.
 intros.
 simpl in |- *.
 apply DotIntro.
 apply axiomGen.
 exact (H0 H1).
Defined.

Section cutNaturalDeduction.

Definition condCutExt (X : gentzen_extension) :=
  forall (Atoms:Set)(T T1 T2 T3 : Term Atoms) (A : Form Atoms),
  X _ T1 T2 ->
  replace T2 T (OneForm A) T3 ->
  sigS
    (fun T' : Term Atoms => (X _ T' T * replace T1 T' (OneForm A) T3)%type).

Definition conditionOKNLP : condCutExt NLP_Sequent.
 unfold condCutExt .
 intros Atoms T T1 T2 T3 A H.
 elim H.
 intros Delta1 Delta2 H0.
 elim (replace_inv2 H0); clear H0; intro H0; elim H0;
 clear H0; intros x H0; elim H0; clear H0; intros H0 H1.
 split with (Comma Delta1 x).
 split.
 rewrite H1.
 constructor 1.
 apply replaceRight; auto.
 split with (Comma x Delta2).
 split.
 rewrite H1.
 constructor 1.
 apply replaceLeft; auto.
Defined.

Definition conditionOKL : condCutExt L_Sequent.
 unfold condCutExt in |- *.
 intros Atoms T T1 T2 T3 A H.
 elim H.
 intros Delta1 Delta2 Delta3 H0.
 elim (replace_inv2 H0); clear H0; intro H0; elim H0; clear H0;
 intros x H0; elim H0; clear H0; intros H0 H1.
 elim (replace_inv2 H0); clear H0; intro H0; elim H0; clear H0; intros x0 H0;
 elim H0; clear H0; intros H0 H2.
 split with (Comma x0 (Comma Delta2 Delta3)).
 split.
 rewrite H1.
 rewrite H2.
 constructor 1.
 apply replaceLeft.
 auto.
 split with (Comma Delta1 (Comma x0 Delta3)).
 split.
 rewrite H1.
 rewrite H2.
 constructor 1.
 apply replaceRight.
 apply replaceLeft; auto.
 split with (Comma Delta1 (Comma Delta2 x)).
 split.
 rewrite H1.
 constructor 1.
 apply replaceRight; apply replaceRight; auto.
 intros Delta1 Delta2 Delta3 H0.
 elim (replace_inv2 H0); clear H0; intro H0; elim H0; clear H0; intros x H0;
  elim H0; clear H0; intros H0 H1.
 split with (Comma (Comma x Delta2) Delta3).
 split.
 rewrite H1.
 constructor 2.
 apply replaceLeft; apply replaceLeft; auto.
 elim (replace_inv2 H0); clear H0; intro H0; elim H0; clear H0; intros x0 H0;
  elim H0; clear H0; intros H0 H2.
 split with (Comma (Comma Delta1 x0) Delta3).
 split.
 rewrite H1.
 rewrite H2.
 constructor 2.
 apply replaceLeft; apply replaceRight; auto.
 split with (Comma (Comma Delta1 Delta2) x0).
 split.
 rewrite H1.
 rewrite H2.
 constructor 2.
 apply replaceRight; auto.
Defined.

Definition condAddExt :
  forall X Y : gentzen_extension,
  condCutExt X ->
  condCutExt Y ->
  condCutExt (add_genExtension X Y).

 intros X Y.
 unfold condCutExt in |- *.
 intros H H0.
 intros Atoms T T1 T2 T3 A H1 R.
 unfold add_genExtension in H1.
 elim H1; clear H1; intro H1.
 elim (H _ T T1 T2 T3 A H1 R).
 intros x H2.
 elim H2; clear H2; intros.
 split with x.
 split.
 unfold add_genExtension in |- *.
 left; auto.
 auto.
 elim (H0 _ T T1 T2 T3 A H1 R).
 intros x H2.
 elim H2; clear H2; intros.
 split with x.
 split.
 unfold add_genExtension in |- *.
 right; auto.
 auto.
Defined.

Definition CutNatDed:
  forall (Atoms: Set)(X : gentzen_extension) (Gamma Delta : Term Atoms)
    (C A : Form Atoms),
  condCutExt X ->
  natDed X Delta A ->
  natDed X Gamma C ->
  forall Gamma' : Term Atoms,
  replace Gamma Gamma' (OneForm A) Delta -> natDed X Gamma' C.
 intros At X Gamma Delta C A Cx H H0.
 elim H0; intros.
 elim (replace_inv1 H1).
 intros H2 H3.
 rewrite H2; rewrite <- H3.
 auto.
 apply SlashIntro.
 apply H1.
 apply replaceLeft; auto.
 apply BackSlashIntro.
 apply H1.
 apply replaceRight; assumption.
 elim (replace_inv2 H3); clear H3; intro H3; elim H3; clear H3; intros x H3;
  elim H3; clear H3; intros H3 H4.
 rewrite H4.
 apply DotIntro.
 apply H1; assumption.
 assumption.
 rewrite H4.
 apply DotIntro.
 auto.
 apply H2; auto.
 elim (replace_inv2 H3); clear H3; intro H3; elim H3; clear H3; intros x H3;
  elim H3; clear H3; intros H3 H4.
 rewrite H4.
 apply SlashElim with B.
 apply H1; auto.
 auto.
 rewrite H4.
 apply SlashElim with B.
 auto.
 apply H2; auto.
 elim (replace_inv2 H3); clear H3; intro H3; elim H3; clear H3; intros x H3;
  elim H3; clear H3; intros H3 H4.
 rewrite H4.
 apply BackSlashElim with B.
 apply H1; auto.
 auto.
 rewrite H4.
 apply BackSlashElim with B.
 auto.
 apply H2; auto.
 elim (doubleReplace r H3); intro H4; elim H4; clear H4; intros x H4; elim H4;
  clear H4; intros H4 H5.
 eapply DotElim.
 eauto.
 auto.
 apply H2; auto.
 eapply DotElim.
 eauto.
 apply H1; auto.
 auto.
 unfold condCutExt in Cx.
 elim (doubleReplace r H2); intro H3; elim H3; clear H3; intros T H3; elim H3;
  clear H3; intros H3 H4.
 eapply NatExt.
 eauto.
 eauto.
 apply H1; assumption.
 elim (Cx _ T T1 T2 Delta A n H3).
 intros x H5.
 elim H5; clear H5; intros.
 elim (replaceSameP H4 x).
 intros x0 H5.
 elim H5; clear H5; intros.
 eapply NatExt.
 eauto.
 eauto.
 apply H1.
 eapply replaceTrans; eauto.
Defined.

Definition composition :
  forall (Atoms:Set)(X : gentzen_extension) (T : Term Atoms) (F1 F2 : Form Atoms),
  condCutExt X ->
  natDed X T F1 ->
  natDed X (OneForm F1) F2 -> natDed X T F2.

 intros.
 apply CutNatDed with (OneForm F1) T F1.
 auto.
 auto.
 auto.
 constructor 1.
Defined.

End cutNaturalDeduction.

Section EquivalenceNaturalGentzen.

Definition natDedToGentzen :
  forall (Atoms:Set)(T : Term Atoms) (C : Form Atoms) (E : gentzen_extension),
  natDed E T C -> gentzenSequent E T C.
 simple induction 1.
 constructor 1.
 intros.
 apply RightSlash.
 assumption.
 intros.
 apply RightBackSlash.
 assumption.
 intros.
 apply RightDot; assumption.
 intros Gamma Delta A B.
 intros.
 apply CutRule with Gamma (Comma (OneForm (Slash A B)) Delta) (Slash A B).
 apply replaceLeft.
 apply replaceRoot.
 assumption.
 apply LeftSlashSimpl.
 assumption.
 constructor 1.
 intros Gamma Delta A B.
 intros.
 apply
  CutRule with Delta (Comma Gamma (OneForm (Backslash B A))) (Backslash B A).
 apply replaceRight.
 apply replaceRoot.
 assumption.
 apply LeftBackSlashSimpl.
 assumption.
 apply Ax.
 intros.
 eapply replaceGentzen'; eauto.
 intros.
 eapply SequentExtension; eauto.
Defined.

Definition gentzenToNatDed:
  forall (Atoms:Set)(T : Term Atoms) (C : Form Atoms) (E : gentzen_extension),
  condCutExt E ->
  gentzenSequent E T C ->
  natDed E T C.

 simple induction 2.
 constructor 1.
 intros.
 constructor 2; assumption.
 intros; constructor 3; assumption.
 intros; constructor 4; assumption.
 intros Delta Gamma; intros.
 apply composition with (deltaTranslation Gamma).
 auto.
 eapply replaceNatDed.
 eauto.
 simpl in |- *.
 eapply SlashElim.
 eapply Axi.
 assumption.
 apply TermToFormDed.
 assumption.
 intros Delta Gamma; intros.
 apply composition with (deltaTranslation Gamma).
 auto.
 eapply replaceNatDed.
 eauto.
 simpl in |- *.
 eapply BackSlashElim.
 eauto.
 constructor 1.
 apply TermToFormDed; assumption.
 intro Gamma; intros.
 apply composition with (deltaTranslation Gamma).
 auto.
 eapply replaceNatDed.
 eauto.
 simpl in |- *; constructor 1.
 apply TermToFormDed; assumption.
 intros Delta Gamma; intros.
 apply composition with (deltaTranslation Gamma).
 auto.
 eapply replaceNatDed.
 eauto.
 simpl in |- *; assumption.
 apply TermToFormDed.
 assumption.
 intros.
 eapply NatExt; eauto.
Defined.

End EquivalenceNaturalGentzen.


Require Import Software.Language.Record.
Require Import Software.Lib.Lists.List.
Require Import Software.Language.RefPassStack.
Require Import Software.Language.Syntax.
Require Import Software.Language.Stack.
Require Import Software.Language.Store.

(** * Types *)

Inductive state : Type :=
  | Cstate: stack -> ref_pass_stack -> store -> state.

Inductive exec_state : Type :=
  | Cexec_state : term -> state -> exec_state.

(** * Functions *)
(** ** State accessors *)

Definition get_stack (st : state) : stack :=
  match st with
  | Cstate sk _ _ => sk
  end.

Definition get_ref_pass_stack (st : state) : ref_pass_stack :=
  match st with
  | Cstate _ rpsk _ => rpsk
  end.

Definition get_store (st : state) : store :=
  match st with
  | Cstate _ _ sr => sr
  end.

Definition set_stack (sk : stack) (st : state) : state :=
  match st with
  | Cstate _ rpsk sr => Cstate sk rpsk sr
  end.

Definition set_ref_pass_stack (rpsk : ref_pass_stack) (st : state) : state :=
  match st with
  | Cstate sk _ sr => Cstate sk rpsk sr
  end.

Definition set_store (sr : store) (st : state) : state :=
  match st with
  | Cstate sk rpsk _ => Cstate sk rpsk sr
  end.

(** ** Function call *)

Section FunctionCalls.

Fixpoint args_to_ref_pass_stack_frame (args : list term) : ref_pass_stack_frame :=
  match args with
  | nil => nil
  | cons t args' =>
    match t with
    | trefpass t' =>
      match t' with
      | tvar n => cons (Some n) (args_to_ref_pass_stack_frame args')
      | _ => cons None (args_to_ref_pass_stack_frame args')
      end
    | _ => cons None (args_to_ref_pass_stack_frame args')
    end
  end.

Fixpoint args_to_stack_frame (args : list term) (context : stack_frame) : stack_frame :=
  match args with
  | nil => nil
  | cons t args' =>
    match t with
    | trefpass t' =>
      match t' with
      | tvar n => cons (nth n context tvoid) (args_to_stack_frame args' context)
      | _ => cons t (args_to_stack_frame args' context)
      end
    | _ => cons t (args_to_stack_frame args' context)
    end
  end.

Fixpoint return_refpass_args (rpsf : ref_pass_stack_frame) (source target : stack_frame) : stack_frame :=
  match rpsf with
  | nil => target
  | cons c rpsf' =>
    match c with
    | None => return_refpass_args rpsf' (tl source) target
    | Some n => return_refpass_args rpsf' (tl source) (replace n (hd tvoid source) target)
    end
  end.

Definition push_call (args : term) (st : state) : state :=
  let sk := get_stack st in
  let rpsk := get_ref_pass_stack st in
  let sk' := push (args_to_stack_frame (rc_to_list args) (hd nil sk)) sk in
  let rpsk' := RefPassStack.push (args_to_ref_pass_stack_frame (rc_to_list args)) rpsk in
  set_ref_pass_stack rpsk' (set_stack sk' st).

Definition pop_call (st : state) : state :=
  let sk := get_stack st in
  let rpsk := get_ref_pass_stack st in
  let sk' := push (return_refpass_args (hd nil rpsk) (hd nil sk) (nth 1 sk nil)) (pop (pop sk)) in
  set_ref_pass_stack (RefPassStack.pop rpsk) (set_stack sk' st).

Hint Resolve Lt.lt_S_n List.nth_indep.

Lemma args_to_ref_pass_stack_frame_length:
  forall args,
  length (args_to_ref_pass_stack_frame args) = length args.
Proof with auto.
  induction args...
  destruct a; simpl...
  destruct a; simpl...
  Qed.

Lemma args_to_ref_pass_stack_frame_correct_1:
  forall args m d1 d2,
  lt m (length args) ->
  (forall n, nth m args d1 <> trefpass (tvar n)) ->
  nth m (args_to_ref_pass_stack_frame args) d2 = None.
Proof with auto.
  induction args; try solve [intros; inversion H].
  destruct m; simpl; intros d1 d2 Hlen Hstruct.
  destruct a; simpl...
  destruct a; simpl...
  exfalso. apply (Hstruct n)...
  destruct a; try solve [simpl; apply IHargs with d1; auto].
  destruct a; try solve [simpl; apply IHargs with d1; auto].
  Qed.

Lemma args_to_ref_pass_stack_frame_correct_2:
  forall args m n d1 d2,
  lt m (length args) ->
  nth m args d1 = trefpass (tvar n) ->
  nth m (args_to_ref_pass_stack_frame args) d2 = Some n.
Proof with auto.
  induction args; try solve [intros; inversion H].
  destruct m; simpl; intros n d1 d2 Hlen Hstruct.
  destruct a; try solve [inversion Hstruct].
  destruct a; try solve [inversion Hstruct].
  inversion Hstruct; subst...
  destruct a; try solve [simpl; apply IHargs with d1; auto].
  destruct a; try solve [simpl; apply IHargs with d1; auto].
  Qed.

Lemma args_to_stack_frame_length:
  forall args context,
  length (args_to_stack_frame args context) = length args.
Proof with auto.
  induction args...
  destruct a; simpl...
  destruct a; simpl...
  Qed.

Lemma args_to_stack_frame_correct_1:
  forall args m context d1 d2 d3,
  lt m (length args) ->
  (forall n, nth m args d1 <> trefpass (tvar n)) ->
  nth m (args_to_stack_frame args context) d2 = nth m args d3.
Proof with auto.
  induction args; try solve [intros; inversion H].
  destruct m; simpl; intros context d1 d2 d3 Hlen Hstruct.
  destruct a; simpl...
  destruct a; simpl...
  exfalso. apply (Hstruct n)...
  destruct a; try solve [simpl; apply IHargs with d1; auto].
  destruct a; try solve [simpl; apply IHargs with d1; auto].
  Qed.

Lemma args_to_stack_frame_correct_2:
  forall args m n context d1 d2,
  lt m (length args) ->
  nth m args d1 = trefpass (tvar n) ->
  nth m (args_to_stack_frame args context) d2 = nth n context tvoid.
Proof with auto.
  induction args; try solve [intros; inversion H].
  destruct m; simpl; intros n context d1 d2 Hlen Hstruct.
  destruct a; try solve [inversion Hstruct].
  destruct a; try solve [inversion Hstruct].
  inversion Hstruct; simpl...
  destruct a; try solve [simpl; apply IHargs with d1; auto].
  destruct a; try solve [simpl; apply IHargs with d1; auto].
  Qed.

Lemma return_refpass_args_length:
  forall rpsf target source,
  length (return_refpass_args rpsf source target) = length target.
Proof with auto using replace_length.
  induction rpsf...
  destruct target.
  destruct a; intros; simpl return_refpass_args...
  destruct a; try solve [intros; simpl; rewrite IHrpsf; auto].
  destruct n; intros; simpl; rewrite IHrpsf; simpl...
  Qed.

Lemma return_refpass_args_correct_1:
  forall rpsf target n source d1 d2 d3,
  (forall m, lt m (length rpsf) -> nth m rpsf d1 <> Some n) ->
  lt n (length target) ->
  nth n (return_refpass_args rpsf source target) d2 = nth n target d3.
Proof with auto.
  induction rpsf. simpl...
  (* rpsf <> nil *)
  destruct target. intros. inversion H0.
  (* target <> nil *)
  destruct a.
  (* rpsf = Some n0 :: rpsf' *)
    intros n0. destruct (EqNat.beq_nat n0 n) eqn:Hnvals.
    (* n0 = n *)
      apply EqNat.beq_nat_true_iff in Hnvals. subst.
      intros. exfalso. apply (H 0).
        simpl. apply Lt.lt_0_Sn.
        reflexivity.
    (* n0 <> n*)
      apply EqNat.beq_nat_false_iff in Hnvals.
      destruct n; destruct n0.
      (* n0 = 0 /\ n = 0 *)
        exfalso. apply Hnvals. reflexivity.
      (* n0 = S n0' /\ n = 0 *)
        intros. simpl return_refpass_args. rewrite IHrpsf with (d1 := d1) (d3 := d3).
          reflexivity.
          intros. apply (H (S m)). simpl. apply Lt.lt_n_S. assumption.
          simpl. assumption.
      (* n0 = 0 /\ n = S n' *)
        intros. simpl return_refpass_args. rewrite IHrpsf with (d1 := d1) (d3 := d3).
          reflexivity.
          intros. apply (H (S m)). simpl. apply Lt.lt_n_S. assumption.
          simpl. rewrite replace_length. assumption.
      (* n0 = S n0' /\ n = S n' *)
        intros. simpl return_refpass_args. rewrite IHrpsf with (d1 := d1) (d3 := d3).
          simpl. rewrite replace_correct_1 with (d2 := d3).
            reflexivity.
            apply Lt.lt_S_n. assumption.
            apply not_eq_n. assumption.
        intros. apply (H (S m)).
          simpl. apply Lt.lt_n_S. assumption.
        simpl. rewrite replace_length. assumption.
  (* rpsf = None :: rpsf' *)
    intros. simpl return_refpass_args. rewrite IHrpsf with (d1 := d1) (d3 := d3).
      reflexivity.
      intros. apply (H (S m)). simpl. apply Lt.lt_n_S. assumption.
      simpl. assumption.
  Qed.

Definition refpass_unique (rpsf : ref_pass_stack_frame) : Prop :=
  forall m m' n d1 d2,
  lt m (length rpsf) ->
  nth m rpsf d1 = Some n ->
  lt m' (length rpsf) ->
  nth m' rpsf d2 = Some n ->
  m' = m.

Lemma refpass_unique_nil:
  refpass_unique nil.
Proof with auto.
  unfold refpass_unique.
  intros. inversion H.
  Qed.

Lemma refpass_unique_cons:
  forall rpsf a,
  refpass_unique (cons a rpsf) ->
  refpass_unique rpsf.
Proof with auto.
  induction rpsf. intros. apply refpass_unique_nil.
  unfold refpass_unique. intros.
  apply (H (S m) (S m') n d1 d2) in H3.
    inversion H3. reflexivity.
    simpl. apply Lt.lt_n_S. assumption.
    simpl. destruct m; assumption.
    simpl. apply Lt.lt_n_S. assumption.
  Qed.

Lemma return_refpass_args_correct_2:
  forall source rpsf target n m d1 d2,
  refpass_unique rpsf ->
  lt m (length rpsf) ->
  nth m rpsf d1 = Some n ->
  lt n (length target) ->
  nth n (return_refpass_args rpsf source target) d2 = nth m source tvoid.
Proof with auto.
  induction source.
  (* source = nil *)
    induction rpsf. intros. inversion H0.
    (* rpsf <> nil *)
    destruct target. intros. inversion H2.
    (* target <> nil *)
    destruct a.
    (* rpsf = Some n0 :: rpsf' *)
      intros n0. destruct (EqNat.beq_nat n0 n) eqn:Hnvals.
      (* n0 = n *)
        apply EqNat.beq_nat_true_iff in Hnvals. subst.
        intros.
        assert (m = 0) as H3.
        {
          unfold refpass_unique in H.
          apply (H 0 m n d1 d1).
            simpl. apply Lt.lt_0_Sn.
            reflexivity.
            assumption.
            assumption.
        }
        subst.
        destruct n.
        (* n = 0 *)
          simpl return_refpass_args.
          rewrite return_refpass_args_correct_1 with (d1 := d1) (d3 := d2).
            reflexivity.
            intros m H3 H4. unfold refpass_unique in H.
              simpl length in H, H0.
              apply (H 0 (S m) 0 d1 d1) in H4; try solve [assumption].
                inversion H4.
                apply Lt.lt_n_S. assumption.
            simpl. apply Lt.lt_0_Sn.
        (* n = S n' *)
          simpl return_refpass_args.
          rewrite return_refpass_args_correct_1 with (d1 := d1) (d3 := d2).
            simpl. rewrite replace_correct_2.
              reflexivity.
              apply Lt.lt_S_n. assumption.
            intros m H3 H4. unfold refpass_unique in H.
              simpl length in H, H0.
              apply (H 0 (S m) (S n) d1 d1) in H4; try solve [assumption].
                inversion H4.
                apply Lt.lt_n_S. assumption.
            simpl. rewrite replace_length. assumption.
      (* n0 <> n *)
        apply EqNat.beq_nat_false_iff in Hnvals.
        destruct n0; destruct n.
        (* n0 = 0 /\ n = 0 *)
          exfalso. apply Hnvals. reflexivity.
        (* n0 = 0 /\ n = S n *)
          destruct m.
          (* m = 0 *)
            intros. inversion H1.
          (* m = S m' *)
            intros. simpl return_refpass_args.
            rewrite IHrpsf with (m := m) (d1 := d1).
              destruct m; reflexivity.
              apply refpass_unique_cons in H. assumption.
              simpl in H0. apply Lt.lt_S_n. assumption.
              assumption.
              simpl. rewrite replace_length. assumption.
        (* n0 = S n0' /\ n = 0 *)
          destruct m.
          (* m = 0 *)
            intros. inversion H1.
          (* m = S m' *)
            intros. simpl return_refpass_args.
            rewrite IHrpsf with (m := m) (d1 := d1).
              destruct m; reflexivity.
              apply refpass_unique_cons in H. assumption.
              simpl in H0. apply Lt.lt_S_n. assumption.
              assumption.
              assumption.
        (* n0 = S n0' /\ n = S n' *)
          destruct m.
          (* m = 0 *)
            intros. inversion H1; subst. exfalso. apply Hnvals. reflexivity.
          (* m = S m' *)
            intros. simpl return_refpass_args.
            rewrite IHrpsf with (m := m) (d1 := d1).
              destruct m; reflexivity.
              apply refpass_unique_cons in H. assumption.
              simpl in H0. apply Lt.lt_S_n. assumption.
              assumption.
              simpl. rewrite replace_length. assumption.
    (* rpsf = None :: rpsf' *)
      destruct m.
      (* m = 0 *)
        intros. inversion H1.
      (* m = S m' *)
        intros. simpl return_refpass_args.
        rewrite IHrpsf with (m := m) (d1 := d1).
          destruct m; reflexivity.
          apply refpass_unique_cons in H. assumption.
          simpl in H0. apply Lt.lt_S_n. assumption.
          assumption.
          simpl. assumption.
  (* source <> nil *)
    destruct rpsf. intros. inversion H0.
    (* rpsf <> nil *)
    destruct target. intros. inversion H2.
    (* target <> nil *)
    destruct o.
    (* rpsf = Some n0 :: rpsf' *)
      intros n0. destruct (EqNat.beq_nat n0 n) eqn:Hnvals.
      (* n0 = n *)
        apply EqNat.beq_nat_true_iff in Hnvals. subst.
        intros.
        assert (m = 0) as H3.
        {
          unfold refpass_unique in H.
          apply (H 0 m n d1 d1).
            simpl. apply Lt.lt_0_Sn.
            reflexivity.
            assumption.
            assumption.
        }
        subst.
        destruct n.
        (* n = 0 *)
          simpl return_refpass_args.
          rewrite return_refpass_args_correct_1 with (d1 := d1) (d3 := d2).
            reflexivity.
            intros m H3 H4. unfold refpass_unique in H.
              simpl length in H, H0.
              apply (H 0 (S m) 0 d1 d1) in H4; try solve [assumption].
                inversion H4.
                apply Lt.lt_n_S. assumption.
            simpl. apply Lt.lt_0_Sn.
        (* n = S n' *)
          simpl return_refpass_args.
          rewrite return_refpass_args_correct_1 with (d1 := d1) (d3 := d2).
            simpl. rewrite replace_correct_2.
              reflexivity.
              apply Lt.lt_S_n. assumption.
            intros m H3 H4. unfold refpass_unique in H.
              simpl length in H, H0.
              apply (H 0 (S m) (S n) d1 d1) in H4; try solve [assumption].
                inversion H4.
                apply Lt.lt_n_S. assumption.
            simpl. rewrite replace_length. assumption.
      (* n0 <> n *)
        apply EqNat.beq_nat_false_iff in Hnvals.
        destruct n0; destruct n.
        (* n0 = 0 /\ n = 0 *)
          exfalso. apply Hnvals. reflexivity.
        (* n0 = 0 /\ n = S n *)
          destruct m.
          (* m = 0 *)
            intros. inversion H1.
          (* m = S m' *)
            intros. simpl.
            rewrite IHsource with (m := m) (d1 := d1).
              reflexivity.
              apply refpass_unique_cons in H. assumption.
              simpl in H0. apply Lt.lt_S_n. assumption.
              assumption.
              simpl. rewrite replace_length. assumption.
        (* n0 = S n0' /\ n = 0 *)
          destruct m.
          (* m = 0 *)
            intros. inversion H1.
          (* m = S m' *)
            intros. simpl.
            rewrite IHsource with (m := m) (d1 := d1).
              destruct m; reflexivity.
              apply refpass_unique_cons in H. assumption.
              simpl in H0. apply Lt.lt_S_n. assumption.
              assumption.
              assumption.
        (* n0 = S n0' /\ n = S n' *)
          destruct m.
          (* m = 0 *)
            intros. inversion H1; subst. exfalso. apply Hnvals. reflexivity.
          (* m = S m' *)
            intros. simpl.
            rewrite IHsource with (m := m) (d1 := d1).
              destruct m; reflexivity.
              apply refpass_unique_cons in H. assumption.
              simpl in H0. apply Lt.lt_S_n. assumption.
              assumption.
              simpl. rewrite replace_length. assumption.
    (* rpsf = None :: rpsf' *)
      destruct m.
      (* m = 0 *)
        intros. inversion H1.
      (* m = S m' *)
        intros. simpl.
        rewrite IHsource with (m := m) (d1 := d1).
          destruct m; reflexivity.
          apply refpass_unique_cons in H. assumption.
          simpl in H0. apply Lt.lt_S_n. assumption.
          assumption.
          simpl. assumption.
  Qed.

Lemma push_call_length:
  forall st args,
  length (get_ref_pass_stack (push_call args st)) = S (length (get_ref_pass_stack st)) /\
  length (get_stack (push_call args st)) = S (length (get_stack st)).
Proof.
  induction st. intros. simpl.
  split; reflexivity.
  Qed.

(** Tail of [ref_pass_stack] is unchanged. *)

Lemma push_call_correct_1:
  forall st m args d1 d2,
  lt m (length (get_ref_pass_stack st)) ->
  nth (S m) (get_ref_pass_stack (push_call args st)) d1 = nth m (get_ref_pass_stack st) d2.
Proof.
  induction st. intros m term d1 d2. simpl. intros.
  apply nth_indep. assumption.
  Qed.

(** Tail of [stack] is unchanged. *)

Lemma push_call_correct_2:
  forall st m args d1 d2,
  lt m (length (get_stack st)) ->
  nth (S m) (get_stack (push_call args st)) d1 = nth m (get_stack st) d2.
Proof.
  induction st. intros m term d1 d2. simpl. intros.
  apply nth_indep. assumption.
  Qed.

(** Head of [ref_pass_stack] is changed. *)

Lemma push_call_correct_3:
  forall st args d,
  hd d (get_ref_pass_stack (push_call args st)) = args_to_ref_pass_stack_frame (rc_to_list args).
Proof.
  induction st. reflexivity.
  Qed.

(** Head of [stack] is changed. *)

Lemma push_call_correct_4:
  forall st args d,
  hd d (get_stack (push_call args st)) = args_to_stack_frame (rc_to_list args) (hd nil (get_stack st)).
Proof.
  induction st. reflexivity.
  Qed.

(** [store] is unchanged. *)

Lemma push_call_correct_5:
  forall st args,
  get_store (push_call args st) = get_store st.
Proof.
  induction st. intros. reflexivity.
  Qed.

Lemma pop_call_length_1:
  forall st n,
  length (get_ref_pass_stack st) = S n ->
  length (get_ref_pass_stack (pop_call st)) = n.
Proof.
  induction st. intros n. simpl.
  destruct r. intros. inversion H.
  simpl. intros. injection H. intros. assumption.
  Qed.

Lemma pop_call_length_2:
  forall st n,
  length (get_stack st) = S (S n) ->
  length (get_stack (pop_call st)) = S n.
Proof.
  induction st. intros n. simpl.
  destruct s. simpl. intros. discriminate H.
  destruct s1. simpl. intros. discriminate H.
  simpl. intros. injection H. intros. rewrite H0. reflexivity.
  Qed.

(** Tail of [ref_pass_stack] is unchanged. *)

Lemma pop_call_correct_1:
  forall st m d1 d2,
  lt (S m) (length (get_ref_pass_stack st)) ->
  nth m (get_ref_pass_stack (pop_call st)) d1 = nth (S m) (get_ref_pass_stack st) d2.
Proof.
  induction st. intros m d1 d2. simpl.
  destruct r. intros. inversion H.
  simpl. intros. apply nth_indep. apply Lt.lt_S_n. assumption.
  Qed.

(** Tail of [stack] is unchanged. *)

Lemma pop_call_correct_2:
  forall st m d1 d2,
  lt (S (S m)) (length (get_stack st)) ->
  nth (S m) (get_stack (pop_call st)) d1 = nth (S (S m)) (get_stack st) d2.
Proof.
  induction st. intros m d1 d2. simpl.
  destruct s. intros. inversion H.
  destruct s1. intros. simpl in H. apply Lt.lt_S_n in H. inversion H.
  simpl. intros. apply nth_indep. do 2 apply Lt.lt_S_n. assumption.
  Qed.

(** Head of [stack] is changed. *)

Lemma pop_call_correct_3:
  forall st d,
  hd d (get_stack (pop_call st)) = return_refpass_args (hd nil (get_ref_pass_stack st)) (hd nil (get_stack st)) (nth 1 (get_stack st) nil).
Proof.
  induction st. reflexivity.
  Qed.

(** [store] is unchanged. *)

Lemma pop_call_correct_4:
  forall st,
  get_store (pop_call st) = get_store st.
Proof.
  induction st. reflexivity.
  Qed.

End FunctionCalls.

(** ** Stack functions *)

Definition write_sk_hd (n : nat) (a : term) (st : state) : state :=
  set_stack (write_hd n a (get_stack st)) st.

Definition read_sk_hd (n : nat) (st : state) : term :=
  read_hd n (get_stack st).

Definition resize_sk_hd (n : nat) (st : state) : state :=
  set_stack (resize_hd n (get_stack st)) st.

(** ** Store functions *)

Definition alloc_sr (a : term) (st : state) : state :=
  set_store (alloc a (get_store st)) st.

Definition write_sr (n : nat) (t : term) (st : state) : state :=
  set_store (write n t (get_store st)) st.

Definition read_sr (n : nat) (st : state) : term :=
  read n (get_store st).

(** ** Function unfolding

    [Arguments] statement with [/] tells tactic [simpl] to unfold these
    functions when arguments before the [/] are provided [[1]].

    [[1]] #<a href="https://coq.inria.fr/distrib/8.4pl4/refman/Reference-Manual010.html##sec395">
           https://coq.inria.fr/distrib/8.4pl4/refman/Reference-Manual010.html##sec395</a># *)

Arguments get_stack st /.
Arguments get_ref_pass_stack st /.
Arguments get_store st /.
Arguments set_stack sk st /.
Arguments set_ref_pass_stack rpsk st /.
Arguments set_store sr st /.
Arguments args_to_ref_pass_stack_frame args /.
Arguments args_to_stack_frame args context /.
Arguments return_refpass_args rpsf source target /.
Arguments push_call args st /.
Arguments pop_call st /.
Arguments write_sk_hd n a st /.
Arguments read_sk_hd n st /.
Arguments resize_sk_hd n st /.
Arguments alloc_sr a st /.
Arguments write_sr n t st /.
Arguments read_sr n st /.

(** * Constants *)

Definition init_state : state := Cstate init_stack init_ref_pass_stack init_store.

(** * Notations *)

Module StateNotations.

Notation "'\stack' sk '\ref_pass_stack' rpsk '\store' sr" :=
  (Cstate sk rpsk sr) (at level 80, format "'[' '[v  ' \stack '/' '[' sk ']' ']' '//' '[v  ' \ref_pass_stack '/' '[' rpsk ']' ']' '//' '[v  ' \store '/' '[' sr ']' ']' ']'") : state_scope.

End StateNotations.


Require Import SfLib.
Require Import Imp.

Require Import String.
Require Import Ascii.

Open Scope list_scope.

Definition isWhite (c : ascii) : bool :=
    let n := nat_of_ascii c in
    orb (orb (beq_nat n 32) (* space *)
             (beq_nat n 9)) (* tab *)
        (orb (beq_nat n 10) (* linefeed *)
             (beq_nat n 13)). (* Carriage return *)

Notation "x '<=?' y" := (ble_nat x y)
    (at level 70, no associativity) : nat_scope.

Definition isLowerAlpha (c : ascii) : bool :=
    let n := nat_of_ascii c in
        andb (97 <=? n) (n <=? 122).

Definition isAlpha (c : ascii) : bool :=
    let n := nat_of_ascii c in
        orb (andb (65 <=? n) (n <=? 90))
            (andb (97 <=? n) (n <=? 122)).

Definition isDigit (c : ascii) : bool :=
    let n := nat_of_ascii c in
        andb (48 <=? n) (n <=? 57).

Inductive chartype := white | alpha | digit | other.

Definition classifyChar (c : ascii) : chartype :=
    if isWhite c then
        white
    else if isAlpha c then
        alpha
    else if isDigit c then
        digit
    else
        other.

Fixpoint list_of_string (s : string) : list ascii :=
    match s with
    | EmptyString => []
    | String c s => c :: (list_of_string s)
    end.

Fixpoint string_of_list (xs : list ascii) : string :=
    fold_right String EmptyString xs.

Definition token := string.

Fixpoint tokenize_helper (cls : chartype) (acc xs : list ascii)
                        : list (list ascii) :=
    let tk := match acc with [] => [] | _::_ => [rev acc] end in
    match xs with
    | [] => tk
    | (x::xs') =>
        match cls, classifyChar x, x with
        | _, _, "(" => tk ++ ["("]::(tokenize_helper other [] xs')
        | _, _, ")" => tk ++ [")"]::(tokenize_helper other [] xs')
        | _, white, _ => tk ++ (tokenize_helper white [] xs')
        | alpha,alpha,x => tokenize_helper alpha (x::acc) xs'
        | digit,digit,x => tokenize_helper digit (x::acc) xs'
        | other,other,x => tokenize_helper other (x::acc) xs'
        | _,tp,x => tk ++ (tokenize_helper tp [x] xs')
    end
end %char.

Definition tokenize (s : string) : list string :=
    map string_of_list (tokenize_helper white [] (list_of_string s)).

Example tokenize_ex1 :
    tokenize "abc12==3 223*(3+(a+c))" %string
  = ["abc"; "12"; "=="; "3"; "223";
     "*"; "("; "3"; "+"; "(";
     "a"; "+"; "c"; ")"; ")"] % string.
Proof. reflexivity. Qed.

Inductive optionE (X:Type) : Type :=
    | SomeE : X -> optionE X
    | NoneE : string -> optionE X.

Implicit Arguments SomeE [[X]].
Implicit Arguments NoneE [[X]].

Notation "'DO' ( x , y ) <== e1 ; e2"
    := (match e1 with
        | SomeE (x,y) => e2
        | NoneE err => NoneE err
        end)
    (right associativity, at level 60).

Notation "'DO' ( x , y ) <-- e1 ; e2 'OR' e3"
    := (match e1 with
        | SomeE (x,y) => e2
        | NoneE err => e3
    end)
    (right associativity, at level 60, e2 at next level).

(* Build a mapping from tokens to nats. A real parser would do
   this incrementally as it encountered new symbols, but passing
   around the symble table inside the parsing functions is a bit
   inconvinient, so instead we do it as a first pass. *)
Fixpoint build_symtable (xs : list token) (n : nat) : (token -> nat) :=
    match xs with
    | [] => (fun s => n)
    | x::xs =>
        if (forallb isLowerAlpha (list_of_string x))
            then (fun s => if string_dec s x then n else (build_symtable xs (S n) s))
            else build_symtable xs n
    end.

Open Scope string_scope.

Definition parser (T : Type) :=
    list token -> optionE (T * list token).

Fixpoint many_helper {T} (p : parser T) acc steps xs :=
match steps, p xs with
| 0, _ => NoneE "Too many recursive calls"
| _, NoneE _ => SomeE ((rev acc), xs)
| S steps', SomeE (t, xs') => many_helper p (t::acc) steps' xs'
end.

(* A (step-indexed) parser which expects zero or more ps *)
Fixpoint many {T} (p : parser T) (steps : nat) : parser (list T) :=
    many_helper p [] steps.

(* A parser which expects a given token, followed by p *)
Definition firstExpect {T} (t : token) (p : parser T) : parser T :=
    fun xs => match xs with
              | x::xs' => if string_dec x t
                            then p xs'
                          else NoneE ("expected '" ++ t ++ "'.")
              | [] => NoneE ("expected '" ++ t ++ "'.")
              end.

(* A parser which expects a particular token *)
Definition expect (t : token) : parser unit :=
    firstExpect t (fun xs => SomeE(tt, xs)).

(* Identifiers *)
Definition parseIdentifier (symtable : string -> nat) (xs : list token)
                        : optionE (id * list token) :=
match xs with
| [] => NoneE "Expected identifier"
| x::xs' =>
    if forallb isLowerAlpha (list_of_string x) then
        SomeE (Id (symtable x), xs')
    else
        NoneE ("Illegal identifier:'" ++ x ++ "'")
end.

(* Numbers *)
Definition parseNumber (xs : list token) : optionE (nat * list token) :=
match xs with
| [] => NoneE "Expected number"
| x::xs' =>
    if forallb isDigit (list_of_string x) then
        SomeE (fold_left (fun n d =>
                    10 * n + (nat_of_ascii d - nat_of_ascii "0"%char))
                (list_of_string x)
                0,
                xs')
    else
        NoneE "Expected number"
end.

(* Parse arithmetic expressions *)
Fixpoint parsePrimaryExp (steps:nat) symtable (xs : list token)
   : optionE (aexp * list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
      DO (i, rest) <-- parseIdentifier symtable xs ;
          SomeE (AId i, rest)
      OR DO (n, rest) <-- parseNumber xs ;
          SomeE (ANum n, rest)
      OR (DO (e, rest) <== firstExpect "(" (parseSumExp steps' symtable) xs;
          DO (u, rest') <== expect ")" rest ;
          SomeE(e,rest'))
  end
with parseProductExp (steps:nat) symtable (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (e, rest) <==
      parsePrimaryExp steps' symtable xs ;
    DO (es, rest') <==
      many (firstExpect "*" (parsePrimaryExp steps' symtable)) steps' rest;
    SomeE (fold_left AMult es e, rest')
  end
with parseSumExp (steps:nat) symtable (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (e, rest) <==
      parseProductExp steps' symtable xs ;
    DO (es, rest') <==
      many (fun xs =>
             DO (e,rest') <--
               firstExpect "+" (parseProductExp steps' symtable) xs;
                                 SomeE ( (true, e), rest')
             OR DO (e,rest') <==
               firstExpect "-" (parseProductExp steps' symtable) xs;
                                 SomeE ( (false, e), rest'))
                            steps' rest;
      SomeE (fold_left (fun e0 term =>
                          match term with
                            (true, e) => APlus e0 e
                          | (false, e) => AMinus e0 e
                          end)
                       es e,
             rest')
  end.

Definition parseAExp := parseSumExp.

(* Parsing boolean expressions *)
Fixpoint parseAtomicExp (steps:nat) (symtable : string -> nat) (xs : list token) :=
match steps with
| 0 => NoneE "Too many recursive calls"
| S steps' =>
    DO (u,rest) <-- expect "true" xs;
        SomeE (BTrue,rest)
    OR DO (u,rest) <-- expect "false" xs;
        SomeE (BFalse,rest)
    OR DO (e,rest) <-- firstExpect "not" (parseAtomicExp steps' symtable) xs ;
        SomeE (BNot e, rest)
    OR DO (e,rest) <-- firstExpect "(" (parseConjunctionExp steps' symtable) xs;
        (DO (u,rest') <== expect ")" rest; SomeE (e,rest))
    OR DO (e,rest) <== parseProductExp steps' symtable xs ;
        (DO (e', rest') <--
            firstExpect "==" (parseAExp steps' symtable) rest ;
            SomeE (BEq e e', rest')
        OR DO (e', rest') <--
            firstExpect "<=" (parseAExp steps' symtable) rest ;
            SomeE (BLe e e', rest')
        OR
            NoneE "Expected '==' or '<=' after arithmetic expression")
end
with parseConjunctionExp (steps:nat) (symtable : string -> nat) (xs : list token) :=
match steps with
| 0 => NoneE "Too many recursive calls"
| S steps' =>
    DO (e, rest) <==
        parseAtomicExp steps' symtable xs ;
    DO (es, rest') <==
        many (firstExpect "&&" (parseAtomicExp steps' symtable)) steps' rest;
    SomeE (fold_left BAnd es e, rest')
end.

Definition parseBExp := parseConjunctionExp.

Fixpoint parseSimpleCommand (steps:nat) (symtable:string->nat) (xs : list token)
    :=
match steps with
| 0 => NoneE "Too many recursive calls"
| S steps' =>
    DO (u, rest) <-- expect "SKIP" xs;
        SomeE (SKIP, rest)
    OR DO (e, rest) <--
        firstExpect "IF" (parseBExp steps' symtable) xs;
       DO (c, rest') <==
        firstExpect "THEN" (parseSequencedCommand steps' symtable) rest;
       DO (c', rest'') <==
        firstExpect "ELSE" (parseSequencedCommand steps' symtable) rest';
       DO (u, rest''') <==
        expect "END" rest'';
       SomeE(IFB e THEN c ELSE c' FI, rest''')
    OR DO (e,rest) <--
        firstExpect "WHILE" (parseBExp steps' symtable) xs;
       DO (c, rest') <==
        firstExpect "DO" (parseSequencedCommand steps' symtable) rest;
       DO (u, rest'') <==
        expect "END" rest';
       SomeE(WHILE e DO c END, rest'')
    OR DO (i, rest) <==
        parseIdentifier symtable xs;
       DO (e, rest') <==
        firstExpect ":=" (parseAExp steps' symtable) rest;
       SomeE(i ::= e, rest')
    end
with parseSequencedCommand (steps:nat) (symtable:string -> nat) (xs : list token) :=
match steps with
| 0 => NoneE "Too many recursive calls"
| S steps' =>
    DO (c, rest) <==
        parseSimpleCommand steps' symtable xs;
    DO (c', rest') <--
        firstExpect ";;" (parseSequencedCommand steps' symtable) rest;
        SomeE(c ;; c', rest')
    OR
        SomeE(c, rest)
end.

Definition bignumber := 1000.

Definition parse (str : string) : optionE (com * list token) :=
    let tokens := tokenize str in
    parseSequencedCommand bignumber (build_symtable tokens 0) tokens.

Eval compute in parse "
    IF x == y + 1 + 2 - y * 6 + 3 THEN
      x := x * 1;;
      y := 0
    ELSE
      SKIP
    END  ".

(*
====>
    SomeE
       (IFB BEq (AId (Id 0))
                (APlus
                   (AMinus (APlus (APlus (AId (Id 1)) (ANum 1)) (ANum 2))
                      (AMult (AId (Id 1)) (ANum 6)))
                   (ANum 3))
        THEN Id 0 ::= AMult (AId (Id 0)) (ANum 1);; Id 1 ::= ANum 0
        ELSE SKIP FI, )
*)

Eval compute in parse "
    SKIP;;
    z:=x*y*(x*x);;
    WHILE x==x DO
      IF z <= z*z && not x == 2 THEN
        x := z;;
        y := z
      ELSE
        SKIP
      END;;
      SKIP
    END;;
    x:=z  ".
(*
====>
     SomeE
        (SKIP;;
         Id 0 ::= AMult (AMult (AId (Id 1)) (AId (Id 2)))
                        (AMult (AId (Id 1)) (AId (Id 1)));;
         WHILE BEq (AId (Id 1)) (AId (Id 1)) DO
           IFB BAnd (BLe (AId (Id 0)) (AMult (AId (Id 0)) (AId (Id 0))))
                     (BNot (BEq (AId (Id 1)) (ANum 2)))
              THEN Id 1 ::= AId (Id 0);; Id 2 ::= AId (Id 0)
              ELSE SKIP FI;;
           SKIP
         END;;
         Id 1 ::= AId (Id 0),
        )
*)

Eval compute in parse "
   SKIP;;
   z:=x*y*(x*x);;
   WHILE x==x DO
     IF z <= z*z && not x == 2 THEN
       x := z;;
       y := z
     ELSE
       SKIP
     END;;
     SKIP
   END;;
   x:=z  ".
(*
=====>
      SomeE
         (SKIP;;
          Id 0 ::= AMult (AMult (AId (Id 1)) (AId (Id 2)))
                (AMult (AId (Id 1)) (AId (Id 1)));;
          WHILE BEq (AId (Id 1)) (AId (Id 1)) DO
            IFB BAnd (BLe (AId (Id 0)) (AMult (AId (Id 0)) (AId (Id 0))))
                     (BNot (BEq (AId (Id 1)) (ANum 2)))
              THEN Id 1 ::= AId (Id 0);;
                   Id 2 ::= AId (Id 0)
              ELSE SKIP
            FI;;
            SKIP
          END;;
          Id 1 ::= AId (Id 0),
         ).
*)