Require Export GeoCoq.Elements.OriginalProofs.proposition_47B.
Require Export GeoCoq.Elements.OriginalProofs.lemma_squareflip.

Section Euclid.

Context `{Ax:area}.

Lemma proposition_47 :
   forall A B C D E F G H K,
   Triangle A B C -> Per B A C -> SQ A B F G -> TS G B A C -> SQ A C K H -> TS H C A B -> SQ B C E D -> TS D C B A ->
   exists X Y, PG B X Y D /\ BetS B X C /\ PG X C E Y /\ BetS D Y E /\ EF A B F G B X Y D /\ EF A C K H X C E Y.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists M L, (PG B M L D /\ BetS B M C /\ PG M C E L /\ BetS D L E /\ BetS L M A /\ Per D L A /\ EF A B F G B M L D)) by (conclude proposition_47B);destruct Tf as [M[L]];spliter.
assert (nCol A B C) by (conclude_def Triangle ).
assert (nCol A C B) by (forward_using lemma_NCorder).
assert (Triangle A C B) by (conclude_def Triangle ).
assert (Per C A B) by (conclude lemma_8_2).
assert (SQ C B D E) by (conclude lemma_squareflip).
assert (TS D B C A) by (conclude lemma_oppositesideflip).
assert (PG B C E D) by (conclude lemma_squareparallelogram).
assert (Par B C E D) by (conclude_def PG ).
assert (TP B C E D) by (conclude lemma_paralleldef2B).
assert (OS E D B C) by (conclude_def TP ).
assert (TS E B C A) by (conclude lemma_planeseparation).
let Tf:=fresh in
assert (Tf:exists m l, (PG C m l E /\ BetS C m B /\ PG m B D l /\ BetS E l D /\ BetS l m A /\ Per E l A /\ EF A C K H C m l E)) by (conclude proposition_47B);destruct Tf as [m[l]];spliter.
assert (neq E D) by (forward_using lemma_betweennotequal).
assert (neq D E) by (conclude lemma_inequalitysymmetric).
assert (Col E l D) by (conclude_def Col ).
assert (Col D L E) by (conclude_def Col ).
assert (Col D E L) by (forward_using lemma_collinearorder).
assert (Col D E l) by (forward_using lemma_collinearorder).
assert (Col E l L) by (conclude lemma_collinear4).
assert (neq L E) by (forward_using lemma_betweennotequal).
assert (neq E L) by (conclude lemma_inequalitysymmetric).
assert (Per E L A) by (conclude lemma_collinearright).
assert (eq l L) by (conclude lemma_droppedperpendicularunique).
assert (eq L l) by (conclude lemma_equalitysymmetric).
assert (BetS L m A) by (conclude cn_equalitysub).
assert (BetS C M B) by (conclude axiom_betweennesssymmetry).
assert (Col L m A) by (conclude_def Col ).
assert (Col L M A) by (conclude_def Col ).
assert (Col L A m) by (forward_using lemma_collinearorder).
assert (Col L A M) by (forward_using lemma_collinearorder).
assert (neq L A) by (forward_using lemma_betweennotequal).
assert (Col A m M) by (conclude lemma_collinear4).
assert (Col M m A) by (forward_using lemma_collinearorder).
assert (Col B M C) by (conclude_def Col ).
assert (Col C B M) by (forward_using lemma_collinearorder).
assert (Col C m B) by (conclude_def Col ).
assert (Col C B m) by (forward_using lemma_collinearorder).
assert (neq C B) by (forward_using lemma_betweennotequal).
assert (Col B M m) by (conclude lemma_collinear4).
assert (Col M m B) by (forward_using lemma_collinearorder).
assert (~ neq M m).
 {
 intro.
 assert (Col m M A) by (forward_using lemma_collinearorder).
 assert (Col m M B) by (forward_using lemma_collinearorder).
 assert (neq m M) by (conclude lemma_inequalitysymmetric).
 assert (Col M A B) by (conclude lemma_collinear4).
 assert (Col M B A) by (forward_using lemma_collinearorder).
 assert (Col M B C) by (forward_using lemma_collinearorder).
 assert (neq M B) by (forward_using lemma_betweennotequal).
 assert (Col B A C) by (conclude lemma_collinear4).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (EF A C K H C M l E) by (conclude cn_equalitysub).
assert (EF A C K H C M L E) by (conclude cn_equalitysub).
assert (EF A C K H M C E L) by (forward_using axiom_EFpermutation).
close.
Qed.

End Euclid.


Load Common.

Require Import FormulaFacts.
Require Import Psatz. (*lia : linear integer arithmetic*)
Require Import Derivations.
Require Import Diophantine.
Require Import UserTactics.

Definition dagger : formula := atom (0, 0).
Definition triangle : formula := atom (0, 1).
Definition to_dagger (s: formula) := arr s dagger.

Definition bullet1 : formula := atom (2, 1).
Definition bullet2 : formula := atom (2, 2).
Definition bullet3 : formula := atom (2, 3).
Definition a_u : formula := atom (3, 1).
Definition a_s : formula := atom (3, 2).
Definition a_p : formula := atom (3, 3).

Definition represent_nat (n : nat) : formula := atom (1, n).
Definition one : formula := represent_nat 1. (*number encoding: [atom (1,n)] = n*)

Definition U (s: formula) := arr (arr (to_dagger s) bullet1) (arr (arr s bullet2) a_u).
Definition S (s t u: formula) :=
    arr (arr (to_dagger s) bullet1)
        (arr (arr (to_dagger t) bullet2)
            (arr (arr (to_dagger u) bullet3) a_s)).
Definition P (s t u: formula) :=
    arr (arr (to_dagger s) bullet1)
        (arr (arr (to_dagger t) bullet2)
            (arr (arr (to_dagger u) bullet3) a_p)).

Definition calC : list formula := [a_u; a_s; a_p; triangle; bullet1; bullet2; bullet3].

Inductive interpretation (s : formula) (n : nat) : Prop :=
  | interpret :
    derivation calC (Formula.arr (to_dagger s) (to_dagger (represent_nat n))) ->
    derivation calC (Formula.arr (to_dagger (represent_nat n)) (to_dagger s)) -> interpretation s n.

Lemma interpretation_of_representation : forall (n: nat), interpretation (represent_nat n) n.
Proof.
split; apply intro_arr; derivation_rule.
Qed.

Lemma interpretation_one : interpretation one 1.
Proof.
split; apply intro_arr; derivation_rule.
Qed.

Definition s_x_u : formula := let a := 1 in let b := 0 in
    quant (
    arr (U (var 0)) (arr ( quant ( arr (U (var b)) (
    arr (S (var a) one (var b)) ( arr (P (var b) one (var b)) triangle)))) triangle)).

Definition s_x_s : formula := let a := 4 in let b := 3 in let c := 2 in let d := 1 in let e := 0 in
    quant ( quant ( quant ( quant ( quant (
    arr (U (var a)) ( arr (U (var b)) ( arr (U (var c)) ( arr (U (var d)) ( arr (U (var e)) (
    arr (S (var a) (var b) (var c)) ( arr (S (var b) one (var d)) ( arr (S (var c) one (var e)) (
    arr (arr (S (var a) (var d) (var e)) triangle) triangle))))))))))))).

Definition s_x_p : formula := let a := 4 in let b := 3 in let c := 2 in let d := 1 in let e := 0 in
    quant ( quant ( quant ( quant ( quant (
    arr (U (var a)) ( arr (U (var b)) ( arr (U (var c)) ( arr (U (var d)) ( arr (U (var e)) (
    arr (P (var a) (var b) (var c)) ( arr (S (var b) one (var d)) ( arr (S (var c) (var a) (var e)) (
    arr (arr (P (var a) (var d) (var e)) triangle) triangle))))))))))))).

Definition represent_diophantine (d : diophantine) (t : formula) : formula :=
  match d with
  | dio_one a => arr (U (var a)) (arr (P (var a) (var a) one) t)
  | dio_sum a b c => arr (U (var a)) (arr (U (var b)) (arr (U (var c)) (arr (S (var a) (var b) (var c)) t)))
  | dio_prod a b c => arr (U (var a)) (arr (U (var b)) (arr (U (var c)) (arr (P (var a) (var b) (var c)) t)))
  end.

Fixpoint represent_diophantines (ds : list diophantine) : formula :=
  match ds with
  | [] => triangle
  | d :: ds' => represent_diophantine d (represent_diophantines ds')
  end.

Fixpoint diophantine_variable_bound (ds : list diophantine) : nat :=
  match ds with
  | [] => 0
  | (dio_one x) :: ds => max (diophantine_variable_bound ds) (1 + x)
  | (dio_sum x y z) :: ds => max (diophantine_variable_bound ds) (max (1 + x) (max (1 + y) (1 + z)))
  | (dio_prod x y z) :: ds => max (diophantine_variable_bound ds) (max (1 + x) (max (1 + y) (1 + z)))
  end.

Definition s_x_d (ds : list diophantine) := let n := diophantine_variable_bound ds in
  quantify_formula n (arr (arr triangle triangle) (represent_diophantines ds)).

Definition ΓI (ds : list diophantine) := [s_x_s; s_x_u; s_x_p; s_x_d ds].

(*we consider encoding of strictly positive natural numbers*)
Definition represents_nat (s : formula) := exists (m : nat),
  s = U (represent_nat m) /\ m > 0.

Definition encodes_nat (s : formula) := exists (m1 : nat) (s1 : formula),
  s = U s1 /\ interpretation s1 m1.

Definition encodes_sum (s : formula) := exists (s1 s2 s3 : formula),
  s = S s1 s2 s3 /\ (exists (m1 m2 m3 : nat), interpretation s1 m1 /\ interpretation s2 m2 /\ interpretation s3 m3 /\ m1 + m2 = m3).

Definition encodes_prod (s : formula) := exists (s1 s2 s3 : formula),
  s = P s1 s2 s3 /\ (exists (m1 m2 m3 : nat), interpretation s1 m1 /\ interpretation s2 m2 /\ interpretation s3 m3 /\ m1 * m2 = m3).

Definition represent_diophantine_repr (f : nat -> formula) (d : diophantine) : list formula :=
  match d with
  | dio_one a => [U (f a); P (f a) (f a) one]
  | dio_sum a b c => [U (f a); U (f b); U (f c); S (f a) (f b) (f c)]
  | dio_prod a b c => [U (f a); U (f b); U (f c); P (f a) (f b) (f c)]
  end.

Lemma represents_nat_intro : forall (s : formula) (m : nat), s = represent_nat m -> m > 0 -> represents_nat (U s).
Proof.
intros. subst. eexists. by split.
Qed.

Lemma encodes_sum_intro : forall (s1 s2 s3 : formula) (m1 m2 m3 : nat),
  interpretation s1 m1 -> interpretation s2 m2 -> interpretation s3 m3 -> m1 + m2 = m3 -> encodes_sum (S s1 s2 s3).
Proof.
intros.
do 3 eexists; split; first reflexivity.
do 3 eexists; do 3 (split; first eassumption).
done.
Qed.

Lemma encodes_prod_intro : forall (s1 s2 s3 : formula) (m1 m2 m3 : nat),
  interpretation s1 m1 -> interpretation s2 m2 -> interpretation s3 m3 -> m1 * m2 = m3 -> encodes_prod (P s1 s2 s3).
Proof.
intros.
do 3 eexists; split; first reflexivity.
do 3 eexists; do 3 (split; first eassumption).
done.
Qed.

Lemma lc_represent_diophantines : forall ds, lc (diophantine_variable_bound ds) (represent_diophantines ds).
Proof.
elim.
constructor.
case; (
  intros; simpl;
  do ? (try lia; constructor);
  eapply Lc.relax; [ eassumption | lia ]).
Qed.

Ltac decompose_lc :=
  do ? (
  match goal with
  | [H : lc _ ?s |- _] =>
    match eval hnf in s with
    | arr _ _ => inversion_clear H
    | var _ => inversion_clear H
    | atom _ => inversion_clear H
    end
  end).

Lemma inspect_chain_diophantines_aux_one : forall (m : nat) (params : list formula) (ds : list diophantine),
  lc m (represent_diophantines ds) ->
  chain (quantify_formula m (arr (arr triangle triangle) (represent_diophantines ds))) (get_label triangle) params ->
  exists (f : nat -> formula),
  tail params = flat_map (represent_diophantine_repr f) ds /\ (forall (x : nat), m <= x -> f x = one).
Proof.
(*no more induction on n*)
intros.
gimme chain; simpl; inversion.
gimme contains. simpl.

move /quantified_arrow_not_contains_atom => //.

gimme contains; move /contains_to_prenex_instantiation.
gimme lc => H_lc.
move /(_ H_lc) => [f [? [H_f H_f2]]].

exists (fun n => match f n with | Some u => u | _ => one end); simpl.
split.

revert dependent ts.
revert dependent u.
revert dependent ds.
elim.
(*no equations*)
simpl.
intros; subst.
gimme chain; inversion; auto.
gimme contains; inversion.
(*at least one equation*)

case.
{
move => x.
simpl. intros * => IH; intros; subst.
decompose_chain.
decompose_lc.
compute.
have : exists u, f x = Some u ∧ lc 0 u by auto.
move => [? [-> ?]].
do ? f_equal.
apply : IH => //.
}

{
move => x y z.
simpl. intros * => IH; intros; subst.
decompose_chain.
decompose_lc.
compute.
have : exists ux, f x = Some ux ∧ lc 0 ux by auto.
have : exists uy, f y = Some uy ∧ lc 0 uy by auto.
have : exists uz, f z = Some uz ∧ lc 0 uz by auto.
move => [? [-> ?]] [? [-> ?]] [? [-> ?]].
do ? f_equal.
apply : IH => //.
}

{
move => x y z.
simpl. intros * => IH; intros; subst.
decompose_chain.
decompose_lc.
compute.
have : exists ux, f x = Some ux ∧ lc 0 ux by auto.
have : exists uy, f y = Some uy ∧ lc 0 uy by auto.
have : exists uz, f z = Some uz ∧ lc 0 uz by auto.
move => [? [-> ?]] [? [-> ?]] [? [-> ?]].
do ? f_equal.
apply : IH => //.
}

move => x Hx.
have : f x = None by auto.
by move => ->.
Qed.

Lemma inspect_chain_diophantines_aux : forall (m : nat) (params : list formula) (ds : list diophantine),
  lc m (represent_diophantines ds) ->
  chain (quantify_formula m (arr (arr triangle triangle) (represent_diophantines ds))) (get_label triangle) params ->
  exists (f : nat -> formula),
  tail params = flat_map (represent_diophantine_repr f) ds.
Proof.
(*no more induction on n*)
intros.
gimme chain; simpl; inversion.
gimme contains. simpl.

move /quantified_arrow_not_contains_atom => //.

gimme contains; move /contains_to_prenex_instantiation.
gimme lc => H_lc.
move /(_ H_lc) => [f [? [H_f ?]]].

exists (fun n => match f n with | Some u => u | _ => one end); simpl.

revert dependent ts.
revert dependent u.
revert dependent ds.
elim.
(*no equations*)
simpl.
intros; subst.
gimme chain; inversion; auto.
gimme contains; inversion.
(*at least one equation*)

case.
{
move => x.
simpl. intros * => IH; intros; subst.
decompose_chain.
decompose_lc.
compute.
have : exists u, f x = Some u ∧ lc 0 u by auto.
move => [? [-> ?]].
do ? f_equal.
apply : IH => //.
}

{
move => x y z.
simpl. intros * => IH; intros; subst.
decompose_chain.
decompose_lc.
compute.
have : exists ux, f x = Some ux ∧ lc 0 ux by auto.
have : exists uy, f y = Some uy ∧ lc 0 uy by auto.
have : exists uz, f z = Some uz ∧ lc 0 uz by auto.
move => [? [-> ?]] [? [-> ?]] [? [-> ?]].
do ? f_equal.
apply : IH => //.
}

{
move => x y z.
simpl. intros * => IH; intros; subst.
decompose_chain.
decompose_lc.
compute.
have : exists ux, f x = Some ux ∧ lc 0 ux by auto.
have : exists uy, f y = Some uy ∧ lc 0 uy by auto.
have : exists uz, f z = Some uz ∧ lc 0 uz by auto.
move => [? [-> ?]] [? [-> ?]] [? [-> ?]].
do ? f_equal.
apply : IH => //.
}
Qed.

Lemma inspect_chain_diophantines : forall (params : list formula) (ds : list diophantine),
  chain (s_x_d ds) (get_label triangle) params ->
  exists (f : nat -> formula),
  tail params = flat_map (represent_diophantine_repr f) ds.
Proof.
eauto using inspect_chain_diophantines_aux, lc_represent_diophantines.
Qed.

Lemma inspect_chain_diophantines_one : forall (params : list formula) (ds : list diophantine),
  chain (s_x_d ds) (get_label triangle) params ->
  exists (f : nat -> formula),
  tail params = flat_map (represent_diophantine_repr f) ds /\ (forall (x : nat), diophantine_variable_bound ds <= x -> f x = one).
Proof.
eauto using inspect_chain_diophantines_aux_one, lc_represent_diophantines.
Qed.

(*HintDb containing instantiation simplification rules*)
Create HintDb simplify_formula.
Lemma simplify_instantiate_arrow : forall s t u n, instantiate s n (arr t u) = arr (instantiate s n t) (instantiate s n u).
Proof. reflexivity. Qed.
Lemma simplify_instantiate_var_eq : forall s n m, n = m -> instantiate s n (var m) = s.
Proof. intros *. move => ->. unfold instantiate. inspect_eqb. reflexivity. Qed.
Lemma simplify_instantiate_var_neq : forall s n m, n <> m -> instantiate s n (var m) = var m.
Proof. intros *. move => ?. unfold instantiate. inspect_eqb. reflexivity. Qed.
Lemma simplify_instantiate_quant : forall s n t, instantiate s n (quant t) = quant (instantiate s (1+n) t).
Proof. reflexivity. Qed.
Lemma simplify_instantiate_atom : forall (t : formula) s n, (exists a, t = atom a) -> instantiate s n t = t.
Proof. intros *. case => a. move => ->. reflexivity. Qed.
Lemma simplify_instantiate_U : forall (s t : formula) (n : nat), instantiate s n (U t) = U (instantiate s n t).
Proof. auto. Qed.
Lemma simplify_instantiate_S : forall (s t1 t2 t3 : formula) (n : nat), instantiate s n (S t1 t2 t3) = S (instantiate s n t1) (instantiate s n t2) (instantiate s n t3).
Proof. auto. Qed.
Lemma simplify_instantiate_P : forall (s t1 t2 t3 : formula) (n : nat), instantiate s n (P t1 t2 t3) = P (instantiate s n t1) (instantiate s n t2) (instantiate s n t3).
Proof. auto. Qed.
Lemma simplify_atom_get_label : forall t, (exists a, t = atom a) -> (atom (get_label t)) = t.
Proof. intros *. case => a. move => ->. reflexivity. Qed.
Lemma simplify_instantiate_one : forall s n, instantiate s n one = one.
Proof. intros; reflexivity. Qed.
Lemma simplify_instantiate_triangle : forall s n, instantiate s n triangle = triangle.
Proof. intros; reflexivity. Qed.

Hint Rewrite simplify_instantiate_U simplify_instantiate_S simplify_instantiate_P : simplify_formula.
Hint Rewrite simplify_instantiate_arrow : simplify_formula.
Hint Rewrite simplify_instantiate_var_eq simplify_instantiate_var_neq using omega : simplify_formula.
Hint Rewrite simplify_instantiate_quant using omega : simplify_formula.
Hint Rewrite @simplify_instantiate_atom using (eexists; reflexivity) : simplify_formula.
Hint Rewrite simplify_instantiate_one simplify_instantiate_triangle : simplify_formula.
Hint Rewrite @simplify_atom_get_label using (eexists; reflexivity) : simplify_formula.
Hint Rewrite Lc.instantiate_eq0 using done : simplify_formula.


Require Import Nijn.Prelude.
Require Import Nijn.Syntax.Signature.

Declare Scope srp.

(** * Strong reduction pairs *)

(** A strong reduction pair provides two relations on the terms. These relations are respected by the term formers and substitution *)
Section StrongReductionPair.
  Context {B F : Type}
          (ar : F -> ty B).

  Record term_order : Type :=
    make_term_order
      {
        tm_gt : forall (C : con B) (A : ty B),
                  tm ar C A -> tm ar C A -> Prop ;
        tm_ge : forall (C : con B) (A : ty B),
                  tm ar C A -> tm ar C A -> Prop
      }.

  Local Notation "x ≺[ O ] y" := (tm_gt O _ _ x y) (at level 70).
  Local Notation "x ≼[ O ] y" := (tm_ge O _ _ x y) (at level 70).

  Definition term_CompatRel
             (C : con B)
             (A : ty B)
             (O : term_order)
    : CompatRel
    := Build_CompatRel (tm ar C A) (tm_gt O C A) (tm_ge O C A).

  Class is_strong_reduction_pair (O : term_order) : Type :=
    {
      gt_isWf : forall (C : con B) (A : ty B),
                  Wf (fun (t₁ t₂ : tm ar C A) => t₁ ≺[ O ] t₂) ;
      compatibility : forall (C : con B) (A : ty B),
                        isCompatRel (term_CompatRel C A O) ;
      sub_gt : forall (C₁ C₂ : con B)
                      (s : sub ar C₁ C₂)
                      (A : ty B)
                      (t₁ t₂ : tm ar C₂ A),
                 t₁ ≺[ O ] t₂
                 -> t₁ [ s ] ≺[ O ] t₂ [ s ] ;
      sub_ge : forall (C₁ C₂ : con B)
                      (s : sub ar C₁ C₂)
                      (A : ty B)
                      (t₁ t₂ : tm ar C₂ A),
                 t₁ ≼[ O ] t₂
                 -> t₁ [ s ] ≼[ O ] t₂ [ s ] ;
      app_gt_l : forall (C : con B)
                        (A₁ A₂ : ty B)
                        (f₁ f₂ : tm ar C (A₁ ⟶ A₂))
                        (t : tm ar C A₁),
                   f₁ ≺[ O ] f₂
                   -> (f₁ · t) ≺[ O ] (f₂ · t) ;
      app_gt_r : forall (C : con B)
                        (A₁ A₂ : ty B)
                        (f : tm ar C (A₁ ⟶ A₂))
                        (t₁ t₂ : tm ar C A₁),
                   t₁ ≺[ O ] t₂
                   -> (f · t₁) ≺[ O ] (f · t₂) ;
      app_ge : forall (C : con B)
                      (A₁ A₂ : ty B)
                      (f₁ f₂ : tm ar C (A₁ ⟶ A₂))
                      (t₁ t₂ : tm ar C A₁),
                 f₁ ≼[ O ] f₂
                 -> t₁ ≼[ O ] t₂
                 -> (f₁ · t₁) ≼[ O ] (f₂ · t₂) ;
      lam_gt : forall (C : con B)
                      (A₁ A₂ : ty B)
                      (f₁ f₂ : tm ar (A₁ ,, C) A₂),
                 f₁ ≺[ O ] f₂
                 -> λ f₁ ≺[ O ] λ f₂ ;
      lam_ge : forall (C : con B)
                      (A₁ A₂ : ty B)
                      (f₁ f₂ : tm ar (A₁ ,, C) A₂),
                 f₁ ≼[ O ] f₂
                 -> λ f₁ ≼[ O ] λ f₂ ;
      beta_ge : forall (C : con B)
                       (A₁ A₂ : ty B)
                       (f : tm ar (A₁ ,, C) A₂)
                       (t : tm ar C A₁),
                  (λ f) · t ≼[ O ] f [ beta_sub t ]
    }.

  Record strong_reduction_pair : Type :=
    make_srp
      {
        orders :> term_order ;
        is_srp : is_strong_reduction_pair orders
      }.

  Global Instance strong_reduction_pair_is_srp
                  (srp : strong_reduction_pair)
    : is_strong_reduction_pair srp
    := is_srp srp.
End StrongReductionPair.

Notation "x ≺[ O ] y" := (tm_gt _ O _ _ x y) (at level 70) : srp.
Notation "x ≼[ O ] y" := (tm_ge _ O _ _ x y) (at level 70) : srp.


Require Import Ynot Basis.
Require Import Ascii String Stream.
Require Import Parsec Charset.
Require Import Arith.
Require Import GradebookApp.
Require Import Parsers.

Set Implicit Arguments.

Module GradebookParser.
  Import ParsecCombinators.Combinators.
  Import ParsecNotation.

(**
  (* A grammar for digits *)
  Definition is_digit(c:ascii):bool :=
    if le_lt_dec (nat_of_ascii "0"%char) (nat_of_ascii c) then
      (if le_lt_dec (nat_of_ascii c) (nat_of_ascii "9"%char) then true else false)
    else false.

  Definition digit : Term ascii  := gsatisfy is_digit.

  (* A parser for digits *)
  Definition digit_p : parser_t digit := satisfy is_digit.

  (** grammar for letters **)
  Definition is_alpha(c:ascii) : bool :=
    if le_lt_dec (nat_of_ascii "a"%char) (nat_of_ascii c) then
      (if le_lt_dec (nat_of_ascii c) (nat_of_ascii "z"%char) then true else false)
    else false.

  Definition is_Alpha(c:ascii) : bool :=
    if le_lt_dec (nat_of_ascii "A"%char) (nat_of_ascii c) then
      (if le_lt_dec (nat_of_ascii c) (nat_of_ascii "Z"%char) then true else false)
    else false.

  Definition is_letter(c:ascii) : bool := if (is_alpha c) then true else (is_Alpha c).

  Definition letter : Term ascii := gsatisfy is_letter.
  Definition letter_p : parser_t letter := satisfy is_letter.

  Definition tab : ascii := ascii_of_nat 9.
  Definition cr : ascii := ascii_of_nat 13.
  Definition lf : ascii := ascii_of_nat 10.

  Definition crlf : Term unit :=
    fun _ => (# cr ^ #lf @ (fun _ => tt))%grammar.

  Definition crlf_p : parser_t crlf.
    refine ((# cr ^ #lf @ (fun _ => tt)))%parser.
  Qed.
**)

  Export GradebookModel.

  Definition id : Term AsciiCharset string := str.
  Definition id_p : parser_t id := str_p.

  Definition pass : Term AsciiCharset string := str.
  Definition pass_p : parser_t pass := str_p.

  Definition assign : Term AsciiCharset string := str.
  Definition assign_p : parser_t assign := str_p.

  Definition grade : Term AsciiCharset Grade := number.
  Definition grade_p : parser_t grade := number_p.

  Definition section : Term AsciiCharset Section :=
    fun var => (digit _ @ (fun v => nat_of_ascii v - nat_of_ascii "0"%char))%grammar.
  Definition section_p : parser_t section :=
    (digit_p @ (fun v => nat_of_ascii v - nat_of_ascii "0"%char))%parser.

  Definition id_pass : Term AsciiCharset (string * string) :=
    fun var =>
      (#"[" ^ id _ ^ ws _ ^ pass _ ^ #"]" @ (fun x => (fst (snd x), fst (snd (snd (snd x))))))%grammar.
  Definition id_pass_p : parser_t id_pass :=
    (#"[" ^ id_p ^ ws_p ^ pass_p ^ #"]" @ (fun x => (fst (snd x), fst (snd (snd (snd x))))))%parser.

  Definition CommandGrammar : Term AsciiCharset ParseCommand :=
    fun var =>
      (    #"G" ^ #"E" ^ #"T" ^ ws _ ^ id_pass _ ^ ws _ ^ id _ ^ ws _ ^ assign _ @
             (fun x =>
               let up := (fst (snd (snd (snd (snd x))))) in
               let id := (fst (snd (snd (snd (snd (snd (snd x))))))) in
               let assign := (snd (snd (snd (snd (snd (snd (snd (snd x)))))))) in
               GetGrade' (fst up) (snd up) id assign)
       ||| #"S" ^ #"E" ^ #"T" ^ ws _ ^ id_pass _ ^ ws _ ^ id _ ^ ws _ ^ assign _ ^ ws _ ^ grade _ @
             (fun x =>
               let up := (fst (snd (snd (snd (snd x))))) in
               let id := (fst (snd (snd (snd (snd (snd (snd x))))))) in
               let assign := (fst (snd (snd (snd (snd (snd (snd (snd (snd x))))))))) in
               let gr := snd (snd (snd (snd (snd (snd (snd (snd (snd (snd x))))))))) in
               SetGrade' (fst up) (snd up) id assign gr)
       ||| #"A" ^ #"V" ^ #"G" ^ ws _ ^ id_pass _ ^ ws _ ^ assign _ @
             (fun x =>
               let up := (fst (snd (snd (snd (snd x))))) in
               let assign := (snd (snd (snd (snd (snd (snd x)))))) in
               Average' (fst up) (snd up) assign))%grammar.

  Definition CommandParser : parser_t CommandGrammar :=
      (    #"G" ^ #"E" ^ #"T" ^ ws_p ^ id_pass_p ^ ws_p ^ id_p ^ ws_p ^ assign_p @
             (fun x =>
               let up := (fst (snd (snd (snd (snd x))))) in
               let id := (fst (snd (snd (snd (snd (snd (snd x))))))) in
               let assign := (snd (snd (snd (snd (snd (snd (snd (snd x)))))))) in
               GetGrade' (fst up) (snd up) id assign)
       ||| #"S" ^ #"E" ^ #"T" ^ ws_p ^ id_pass_p ^ ws_p ^ id_p ^ ws_p ^ assign_p ^ ws_p ^ grade_p @
             (fun x =>
               let up := (fst (snd (snd (snd (snd x))))) in
               let id := (fst (snd (snd (snd (snd (snd (snd x))))))) in
               let assign := (fst (snd (snd (snd (snd (snd (snd (snd (snd x))))))))) in
               let gr := snd (snd (snd (snd (snd (snd (snd (snd (snd (snd x))))))))) in
               SetGrade' (fst up) (snd up) id assign gr)
       ||| #"A" ^ #"V" ^ #"G" ^ ws_p ^ id_pass_p ^ ws_p ^ assign_p @
             (fun x =>
               let up := (fst (snd (snd (snd (snd x))))) in
               let assign := (snd (snd (snd (snd (snd (snd x)))))) in
               Average' (fst up) (snd up) assign))%parser.

End GradebookParser.

Module HttpGradebookInterface (AP : GradebookType) : AppInterface with Module A := AP.
  Module A := AP.

  Definition grammar := GradebookParser.CommandGrammar.
  Definition parser  := GradebookParser.CommandParser.

  Open Local Scope string_scope.
  Export Basis.

  Definition header : list ascii := str2la (
(*    "<?xml version=""1.0""?>" ++  *)
    "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01//EN"" ""http://www.w3.org/TR/html4/strict.dtd"">" ++
    "" ++
    " " ++
    "  <title>Course Grade Server</title>" ++
    " " ++
    " " ++
    "  <form action=""http://127.0.0.1:8081"" method=""GET"" target=""_self"">" ++
    "   Query <input type=""text"" name=""q"" size=""25"" maxlength=""40"" /> <input type=""submit"" />" ++
    "  </form>" ++
    "
").

  Definition footer : list ascii := str2la (
    " " ++
    "").

  Definition printer (res : Status) : list ascii :=
    List.app header
    (List.app
      match res with
        | ERR_NOTPRIVATE => str2la "Error: Not Private"
        | ERR_BADGRADE => str2la "Error: Bad Grade"
        | ERR_NOINV => str2la "Error: No Invariant"
        | OK => str2la "Success!"
        | RET x => List.app (str2la "Result: ") (str2la (ntos x))
      end
      footer).

  Definition err (_ : consumed_t) :=
    List.app header (List.app (str2la "Error: Malformed query") footer).

End HttpGradebookInterface.