Require Import Coq.Strings.String Coq.ZArith.ZArith.
From coqutil Require Import Word.Interface Word.Properties.
From coqutil Require Import Tactics.rdelta Z.div_mod_to_equations.
Require Import coqutil.Z.Lia.
Local Open Scope Z_scope.

(** Bounds propagation *)

Lemma Z__range_add a0 a a1 (Ha: a0 <= a < a1) b0 b b1 (Hb : b0 <= b < b1)
      : a0+b0 <= a+b < a1 + b1 - 1.
Proof. Lia.nia. Qed.

Lemma Z__range_sub a0 a a1 (Ha: a0 <= a < a1) b0 b b1 (Hb : b0 <= b < b1)
      : a0-b1+1 <= a-b < a1 - b0.
Proof. Lia.nia. Qed.
Lemma Z__range_div_pos_const_r n0 n n1 (Hn : n0 <= n < n1) d (Hd : 0 < d)
  : n0/d <= n/d < n1/d + 1.
Proof. Z.div_mod_to_equations. Lia.nia. Qed.
Lemma Z__range_mul_nonneg a0 a a1 (Ha: a0 <= a < a1) b0 b b1 (Hb : b0 <= b < b1) (Ha0 : 0 <= a0) (Hb0 : 0 <= b0)
      : a0*b0 <= a*b < (a1-1)*(b1-1) + 1.
Proof. Lia.nia. Qed.
Lemma boundscheck {x0 x x1} (H: x0 <= x < x1) {X0 X1} (Hcheck : andb (X0 <=? x0) (x1 <=? X1) = true) : X0 <= x < X1.
Proof. eapply andb_prop in Hcheck; case Hcheck; intros H1 H2; eapply Z.leb_le in H1; eapply Z.leb_le in H2. blia. Qed.
Lemma boundscheck_lt {x0 x x1} (H: x0 <= x < x1) {X1} (Hcheck: Z.ltb x1 X1 = true) : x < X1.
Proof. eapply Z.ltb_lt in Hcheck. blia. Qed.
Lemma bounded_constant c : c <= c < c+1. Proof. blia. Qed.

Ltac named_pose_proof pf :=
  let H := fresh in
  let __ := match constr:(Set) with _ => pose proof pf as H end in
  H.
Ltac named_pose pf :=
  let H := fresh in
  let __ := match constr:(Set) with _ => pose pf as H end in
  H.
Ltac named_pose_asfresh pf x :=
  let H := fresh x in
  let __ := match constr:(Set) with _ => pose pf as H end in
  H.

Ltac named_pose_asfresh_or_id x n :=
  let y := match constr:(Set) with _ => named_pose_asfresh x n | _ => x end in
  y.

Ltac requireZcst z :=
  lazymatch Coq.setoid_ring.InitialRing.isZcst z with
  | true => idtac
  end.
Ltac requireZcstExpr e :=
  match e with
  | Z.pred ?x => requireZcstExpr x
  | Z.succ ?x => requireZcstExpr x
  | Z.ones ?x => requireZcstExpr x
  | Z.opp ?x => requireZcstExpr x
  | Z.lnot ?x => requireZcstExpr x
  | Z.log2 ?x => requireZcstExpr x
  | Z.log2_up ?x => requireZcstExpr x
  | Z.add ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.sub ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.mul ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.div ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.modulo ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.quot ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.rem ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.pow ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.shiftl ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.shiftr ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.land ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.lor ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.lxor ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.ldiff ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.clearbit ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.setbit ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.min ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.max ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.gcd ?x ?y => requireZcstExpr x; requireZcstExpr y
  | Z.lcm ?x ?y => requireZcstExpr x; requireZcstExpr y
  | _ => requireZcst e
  end.

Ltac zsimp x :=
  match constr:(Set) with
  | _ => let __ := requireZcstExpr x in let y := eval cbv in x in y
  | _ => x
  end.

Local Notation "zbsimp! H" :=
  (ltac:(
     lazymatch type of H with
           ?L <= ?X < ?R =>
           let L := zsimp L in
           let R := zsimp R in
           exact ((H : L <= X < R))
         end
  )) (at level 10, only parsing).

Ltac rbounded e :=
  let re := rdelta e in
  match goal with
  | H :  _ <= e < _ |- _ => H
  | _ =>
    match re with
    | word.unsigned ?a =>
      named_pose_proof (zbsimp! (Properties.word.unsigned_range a : _ <= e < _))
    | Z.div ?a ?b => (* TODO: non-constant denominator? *)
      let __ := match constr:(Set) with _ => requireZcstExpr b end in
      let Ha := rbounded a in
      named_pose_proof (zbsimp! (Z__range_div_pos_const_r _ a _ Ha b ltac:(eapply Z.ltb_lt; exact eq_refl) : _ <= e < _))
    | Z.modulo ?a ?b => (* TODO: non-constant denominator? *)
      let __ := match constr:(Set) with _ => requireZcstExpr b end in
      named_pose_proof (zbsimp! (Z.mod_pos_bound a b ltac:(eapply Z.ltb_lt; exact eq_refl) : _ <= e < _))
    | ?op ?a ?b =>
      let Ha := rbounded a in
      let Hb := rbounded b in
      let a0 := match type of Ha with ?a0 <= _ < ?a1 => a0 end in
      let a1 := match type of Ha with ?a0 <= _ < ?a1 => a1 end in
      let b0 := match type of Hb with ?b0 <= _ < ?b1 => b0 end in
      let b1 := match type of Hb with ?b0 <= _ < ?b1 => b1 end in
      match op with
      | Z.add => named_pose_proof (zbsimp! (Z__range_add a0 a a1 Ha b0 b b1 Hb : a0 + b0 <= e < a1 + b1 - 1))
      | Z.sub => named_pose_proof (zbsimp! (Z__range_sub a0 a a1 Ha b0 b b1 Hb : a0-b1+1 <= e < a1-b0))
      | Z.mul => named_pose_proof (zbsimp! (Z__range_mul_nonneg a0 a a1 Ha b0 b b1 Hb (Zle_bool_imp_le 0 a0 eq_refl) (Zle_bool_imp_le 0 b0 eq_refl) : _ <= e < _))
      (* TODO: pow *)
      (* TODO: and, or, xor, ndn *)
      end
    end
  | _ =>
    let __ := match constr:(Set) with _ => requireZcstExpr re end in
    constr:(zbsimp! (bounded_constant e))
  end.

(** Abstract interpretation *)

Definition absint_eq {T} := @eq T.
Definition absint_eq_refl {T} v := ((@eq_refl T v) : @absint_eq T v v).
Local Infix "=~>" := absint_eq (at level 70, no associativity).

Module unsigned.
  Section WithWord.
    Context {width : Z} {word : word.word width} {word_ok : word.ok word}.
    Local Notation "absint_lemma! pf" := (ltac:(
      cbv [absint_eq] in *;
      etransitivity; [ eapply pf | ]; cycle -1;
        [unshelve (repeat match goal with
          | |- _ => progress unfold word.wrap in *
          | |-context [Z.shiftr ?x (word.unsigned ?y)] => assert_fails(is_evar x||is_evar y);
            setoid_rewrite (Z.shiftr_div_pow2 x (word.unsigned y) (proj1 (Properties.word.unsigned_range _)))
          | |-context [Z.shiftl ?x (word.unsigned ?y)] => assert_fails(is_evar x||is_evar y);
            setoid_rewrite (Z.shiftl_mul_pow2 x (word.unsigned y) (proj1 (Properties.word.unsigned_range _)))
          | |-context [?x mod (2^?y)] => assert_fails(is_evar x||is_evar y);
            rewrite (Z.mod_small x (2^y)) by shelve
          | |-context [word.unsigned ?x] => assert_fails(is_evar x);
            erewrite (_:word.unsigned _=_) by shelve
          end; exact eq_refl)
        |..];
        (* WHY do I need [> here? *)
        [> (repeat match goal with
                   | H: ?P |- ?G => assert_fails (has_evar P || has_evar G); rewrite H
                   end;
            match reverse goal with H : ?e |- ?G => is_evar e; unify e G; exact H end).. ]
      )) (at level 10, only parsing).

    Definition absint_add (x y : word.rep) ux Hx uy Hy Hbounds : _ =~> _ :=
      absint_lemma! (word.unsigned_add x y).
    Definition absint_sub (x y : word.rep) ux Hx uy Hy Hbounds : word.unsigned _ =~> _ :=
      absint_lemma! (word.unsigned_sub x y).
    Definition absint_mul (x y : word.rep) ux Hx uy Hy Hbounds : word.unsigned _ =~> _ :=
      absint_lemma! (word.unsigned_mul x y).
    Definition absint_and (x y : word.rep) ux Hx uy Hy : word.unsigned _ =~> _ :=
      absint_lemma! (Properties.word.unsigned_and_nowrap x y).
    Definition absint_or (x y : word.rep) ux Hx uy Hy : word.unsigned _ =~> _ :=
      absint_lemma! (Properties.word.unsigned_or_nowrap x y).
    Definition absint_xor (x y : word.rep) ux Hx uy Hy : word.unsigned _ =~> _ :=
      absint_lemma! (Properties.word.unsigned_xor_nowrap x y).
    Definition absint_ndn (x y : word.rep) ux Hx uy Hy : word.unsigned _ =~> _ :=
      absint_lemma! (Properties.word.unsigned_ndn_nowrap x y).
    Definition absint_sru (x y : word.rep) ux Hx uy Hy Hshift  : word.unsigned _ =~> _ :=
      absint_lemma! (Properties.word.unsigned_sru_nowrap x y).
    Definition absint_slu (x y : word.rep) ux Hx uy Hy Hrange Hshift : word.unsigned _ =~> _ :=
      absint_lemma! (word.unsigned_slu x y).
    Definition absint_divu (x y : word.rep) ux Hx uy Hy Hnz  : word.unsigned _ =~> _ :=
      absint_lemma! (Properties.word.unsigned_divu_nowrap x y).
    Definition absint_modu (x y : word.rep) ux Hx uy Hy Hnz  : word.unsigned _ =~> _ :=
      absint_lemma! (Properties.word.unsigned_modu_nowrap x y).
    Implicit Types (x y : word).
    (* TODO use it *)
    Lemma absint_opp x (ux: Z) (Hx: word.unsigned x = ux) (Hnz: ux <> 0):
      word.unsigned (word.opp x) =~> 2^width - ux.
    Proof.
      rewrite word.unsigned_opp. cbv [word.wrap].
      rewrite Z_mod_nz_opp_full.
      - rewrite Z.mod_small; [rewrite Hx; reflexivity|]. apply word.unsigned_range.
      - rewrite Z.mod_small; [rewrite Hx; apply Hnz|]. apply word.unsigned_range.
    Qed.

    Lemma absint_mask_r x y ux (Hx : word.unsigned x = ux) uy (Hy : word.unsigned y = uy) (Huy : uy = Z.ones (Z.log2 uy+1)):
       word.unsigned (word.and x y) =~> Z.modulo ux (uy+1).
    Proof.
      etransitivity; [eapply absint_and; eauto|].
      rewrite Huy.
      rewrite Z.land_ones, Z.ones_equiv; repeat (eapply f_equal2 || blia).
      enough (Z.log2 0 <= Z.log2 uy) by (change (Z.log2 0) with 0 in *; blia).
      eapply Z.log2_le_mono; subst uy; eapply word.unsigned_range.
    Qed.
    Lemma absint_mask_l y x uy (Hy : word.unsigned y = uy) ux (Hx : word.unsigned x = ux) (Huy : uy = Z.ones (Z.log2 uy+1)):
       word.unsigned (word.and y x) =~> Z.modulo ux (uy+1).
    Proof.
      etransitivity; [eapply absint_and; eauto|].
      rewrite Z.land_comm.
      rewrite Huy.
      rewrite Z.land_ones, Z.ones_equiv; repeat (eapply f_equal2 || blia).
      enough (Z.log2 0 <= Z.log2 uy) by (change (Z.log2 0) with 0 in *; blia).
      eapply Z.log2_le_mono; subst uy; eapply word.unsigned_range.
    Qed.
  End WithWord.

  Ltac zify_expr e :=
    let re := rdelta e in
    lazymatch type of e with
    | @word.rep ?width ?word_parameters =>
      match re with
      | _ => match goal with H: word.unsigned e =~> _ |- _ => H end
      | word.of_Z ?a =>
        let Ba := rbounded a in
        named_pose_proof (word.unsigned_of_Z_nowrap a (boundscheck (X0:=0) (X1:=2^width) Ba (eq_refl true)) : @absint_eq Z (@word.unsigned _ word_parameters e) a)
      | word.and ?a ?b =>
        let Ha := zify_expr a in let Ra := lazymatch type of Ha with _ =~> ?x => x end in
        let Hb := zify_expr b in let Rb := lazymatch type of Hb with _ =~> ?x => x end in
        named_pose_proof (absint_mask_r a b Ra Ha Rb Hb eq_refl : @absint_eq Z (@word.unsigned _ word_parameters e) (Z.modulo Ra (Rb+1)))
      | word.and ?a ?b =>
        let Ha := zify_expr a in let Ra := lazymatch type of Ha with _ =~> ?x => x end in
        let Hb := zify_expr b in let Rb := lazymatch type of Hb with _ =~> ?x => x end in
        named_pose_proof (absint_mask_l a b Ra Ha Rb Hb eq_refl : @absint_eq Z (@word.unsigned _ word_parameters e) (Z.modulo Rb (Ra+1)))
      | ?op ?a ?b =>
        let Ha := zify_expr a in let Ra := lazymatch type of Ha with _ =~> ?x => x end in
        let Hb := zify_expr b in let Rb := lazymatch type of Hb with _ =~> ?x => x end in
        match op with
        | word.and =>
          named_pose_proof constr:(absint_and a b Ra Ha Rb Hb : @absint_eq Z (@word.unsigned _ word_parameters e) (Z.land Ra Rb))
        | word.or =>
          named_pose_proof constr:(absint_or a b Ra Ha Rb Hb : @absint_eq Z (@word.unsigned _ word_parameters e) (Z.lor Ra Rb))
        | word.xor =>
          named_pose_proof constr:(absint_xor a b Ra Ha Rb Hb : @absint_eq Z (@word.unsigned _ word_parameters e) (Z.lxor Ra Rb))
        | word.ndn =>
          named_pose_proof constr:(absint_ndn a b Ra Ha Rb Hb : @absint_eq Z (@word.unsigned _ word_parameters e) (Z.ldiff Ra Rb))

        | word.add =>
          let Re := named_pose_asfresh_or_id constr:(Ra+Rb) e in
          let Be := rbounded Re in
          let Hbounds := match type of Be with ?x0 <= ?x < ?x1 =>
                           constr:(@boundscheck x0 x x1 Be 0 (2^width) (@eq_refl bool true)) end in
          named_pose_proof constr:(absint_add a b Ra Ha Rb Hb Hbounds : @absint_eq Z (@word.unsigned _ word_parameters e) Re)
        | word.sub =>
          let Re := named_pose_asfresh_or_id constr:(Ra-Rb) e in
          let Be := rbounded Re in
          let Hbounds := match type of Be with ?x0 <= ?x < ?x1 =>
                           constr:(@boundscheck x0 x x1 Be 0 (2^width) (@eq_refl bool true)) end in
          named_pose_proof constr:(absint_sub a b Ra Ha Rb Hb Hbounds : @absint_eq Z (@word.unsigned _ word_parameters e) Re)
        | word.mul =>
          let Re := named_pose_asfresh_or_id constr:(Ra*Rb) e in
          let Be := rbounded Re in
          let Hbounds := match type of Be with ?x0 <= ?x < ?x1 =>
                           constr:(@boundscheck x0 x x1 Be 0 (2^width) (@eq_refl bool true)) end in
          named_pose_proof constr:(absint_mul a b Ra Ha Rb Hb Hbounds : @absint_eq Z (@word.unsigned _ word_parameters e) Re)

        | word.sru =>
          let Re := named_pose_asfresh_or_id constr:((Ra / 2^Rb)) e in
          let Bb := rbounded Rb in
          let pf := constr:(absint_sru a b Ra Ha Rb Hb (@boundscheck_lt _ Rb _ Bb width eq_refl): @absint_eq Z (@word.unsigned _ word_parameters e) Re) in
          named_pose_proof pf
        | word.slu =>
          let Re := named_pose_asfresh_or_id constr:((Ra * 2^Rb)) e in
          let Bb := rbounded Rb in
          let Be := rbounded Re in
          named_pose_proof (absint_slu a b Ra Ha Rb Hb (boundscheck (X0:=0) (X1:=2^width) Be (eq_refl true)) (@boundscheck_lt _ Rb _ Bb width eq_refl): @absint_eq Z (@word.unsigned _ word_parameters e) Re)
        | _ => (* unknown binop or bad bounds, don't backtrack to keep Ha and Hb *)
          constr:(@absint_eq_refl Z (@word.unsigned _ word_parameters e))
         (* TODO: divu, modu (how do we prove denominator nonzero?) *)
        end
      | _ =>
        constr:(@absint_eq_refl Z (@word.unsigned _ word_parameters e))
      end
    | Z =>
      match e with
      | _ => match goal with H: e =~> _ |- _ => H end
      | word.unsigned ?a => zify_expr a
      | _ => constr:(@absint_eq_refl Z e)
      end
    end.
End unsigned.

Require coqutil.Word.Naive.
Module absint_test.
  Import Word.Naive.
  Fixpoint goal (x : word32) (n : nat) : Prop
    := match n with
       | O => True
       | S n' => let x := word.add x x in goal x n'
       end.
  Goal forall x X, 1 <= X < 2^60 -> absint_eq (word.unsigned x) X -> goal x 7.
  Proof.
    cbv beta iota delta [goal].
    intros.

    let e := match goal with x := _ |- _ => x end in
    let e := constr:(word.ndn (word.xor (word.or (word.and (word.sub (word.mul (word.slu (word.sru e (word.of_Z 16)) (word.of_Z 3)) x) x) x) x) x) x) in
    let H := unsigned.zify_expr e in
    idtac H.

   clear.
   assert (x3 : word32) by exact (word.of_Z 0).
  let e :=
    constr:(
word.unsigned
  (word.add
     (word.add
        (word.sru
           (word.add
              (word.and (word.sru x3 (word.of_Z 16)) (word.of_Z 16383))
              (word.of_Z 3)) (word.of_Z 2))
        (word.sru
           (word.add
              (word.and (word.sru x3 (word.of_Z 16)) (word.of_Z 16383))
              (word.of_Z 3)) (word.of_Z 2)))
     (word.add
        (word.sru
           (word.add
              (word.and (word.sru x3 (word.of_Z 16)) (word.of_Z 16383))
              (word.of_Z 3)) (word.of_Z 2))
        (word.sru
           (word.add
              (word.and (word.sru x3 (word.of_Z 16)) (word.of_Z 16383))
              (word.of_Z 3)) (word.of_Z 2))))) in
     let H := unsigned.zify_expr e in
     idtac H;
     repeat match goal with H:?x =~> ?x |- _ => clear H end.

    exact I.
  Qed.

  Goal forall x y, 0 <= x < 5 -> 10 <= y < 20 -> True.
  Proof.
    intros.

    set (a := x+y).
    set (b := y+x).
    set (c := a*b+7).

    let e := constr:(a + y mod 2 * (b*(x*y/4)) + c) in
    let H := rbounded e in
    cbn in *.

    let e := constr:(a*c + b) in
    let H := rbounded e in
    idtac H;
    cbn in *.
    exact I.
  Qed.
End absint_test.


Require Export Classical.
Require Import ClassicalChoice.
Require Export Relation_Definitions.
Require Import Relation_Definitions_Implicit.
Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Import Proj1SigInjective.
Require Import InverseImage.

Section ZL'.

Variable T:Type.
Variable R:relation T.
Hypothesis ord:order R.
Definition chain (S: Ensemble T) : Prop :=
  forall x y:T, In S x -> In S y -> (R x y \/ R y x).
Definition maximal (x:T) : Prop :=
  forall y:T, R x y -> x = y.
Variable chain_sup: forall S: Ensemble T, chain S ->
  { x:T | (forall y:T, In S y -> R y x) /\
    (forall z:T, (forall y:T, In S y -> R y z) -> R x z) }.
Variable inflation: forall x:T,
  { y:T | R x y /\ x <> y /\ forall z:T, R x z -> R z y ->
                                     z = x \/ z = y }.

Inductive tower : Ensemble T :=
  | sup_intro: forall (S: Ensemble T), Included S tower ->
      forall c:chain S,
      In tower (proj1_sig (chain_sup S c))
  | inflation_intro: forall x:T, In tower x ->
      In tower (proj1_sig (inflation x)).

Lemma tower_is_chain: chain tower.
Proof.
unfold chain.
intros.
revert x H.
induction H0.
intros.
case (classic (forall y:T, In S y -> R y x)).
right.
apply (proj2_sig (chain_sup S c)).
assumption.

intro.
apply not_all_ex_not in H2.
destruct H2.
apply imply_to_and in H2.
destruct H2.
left.
apply (ord_trans ord) with x0.
pose proof (H0 x0 H2 x H1).
tauto.
apply (proj2_sig (chain_sup S c)).
assumption.

pose proof (proj2_sig (inflation x)).
simpl in H0.
destruct H0.
destruct H1.
remember (proj1_sig (inflation x)) as x'.

assert (forall y:T, In tower y -> R y x \/ R x' y).
intros.
induction H3.
case (classic (forall x0:T, In S x0 -> R x0 x)).
left.
apply (proj2_sig (chain_sup S c)).
assumption.

right.
apply not_all_ex_not in H5.
destruct H5.
apply imply_to_and in H5.
destruct H5.
apply (ord_trans ord) with x0.
pose proof (H4 x0).
tauto.
apply (proj2_sig (chain_sup S c)).
assumption.

assert (In tower x').
rewrite Heqx'.
apply inflation_intro.
assumption.

destruct IHtower0.
assert (In tower (proj1_sig (inflation x0))).
apply inflation_intro.
assumption.
case (IHtower (proj1_sig (inflation x0)) H6).
left.
assumption.
intro.
pose proof (proj2_sig (inflation x0)).
simpl in H8.
assert (x = x0 \/ x = proj1_sig (inflation x0)).
apply H8.
assumption.
assumption.
case H9.
right.
rewrite Heqx'.
rewrite H10.
apply (ord_refl ord).
left.
rewrite H10.
apply (ord_refl ord).
right.
apply (ord_trans ord) with x0.
assumption.
apply (proj2_sig (inflation x0)).

intros.
case (H3 x0 H4).
left.
apply (ord_trans ord) with x.
assumption.
assumption.
right.
assumption.
Qed.

(* can now show the given hypotheses are contradictory *)
Lemma ZL': False.
Proof.
pose proof (proj2_sig (chain_sup tower tower_is_chain)).
simpl in H.
remember (proj1_sig (chain_sup tower tower_is_chain)) as x0.
assert (In tower x0).
rewrite Heqx0.
constructor 1.
auto with sets.

pose (x' := proj1_sig (inflation x0)).
assert (In tower x').
constructor 2.
assumption.

pose proof (proj2_sig (inflation x0)).
simpl in H2.
destruct H2.
destruct H3.
contradict H3.
apply (ord_antisym ord).
assumption.
destruct H.
apply H.
assumption.
Qed.

End ZL'.

Arguments chain {T}.
Arguments maximal {T}.

Section ZL.

(* get rid of the need for a sup function and immediate successors *)

Variable T:Type.
Variable R:relation T.
Hypothesis ord: order R.
Hypothesis ub_of_chain: forall S:Ensemble T, chain R S ->
  exists x:T, forall y:T, In S y -> R y x.

Definition chains := {S:Ensemble T | chain R S}.
Definition chains_ord := (fun S1 S2:chains =>
  Included (proj1_sig S1) (proj1_sig S2)).

Lemma chains_order: order chains_ord.
Proof.
constructor.
unfold reflexive.
unfold chains_ord.
auto with sets.

unfold transitive.
unfold chains_ord.
auto with sets.

unfold antisymmetric.
unfold chains_ord.
intros.
apply proj1_sig_injective.
auto with sets.
Qed.

Require Export EnsemblesSpec.

Definition chains_sup_def : forall F: Ensemble chains,
  chain chains_ord F -> chains.
refine (fun F H => exist _ [ x:T | exists S:chains, In F S /\
                             In (proj1_sig S) x ] _).
red; intros.
destruct H0.
destruct H1.
destruct H0.
destruct H1.
pose proof (H x0 x1).
destruct x0.
destruct x1.
simpl in H0.
destruct H0.
simpl in H1.
destruct H1.
apply H2 in H0.
unfold chains_ord in H0.
simpl in H0.
destruct H0.
apply c0.
apply H0.
exact H3.
exact H4.

apply c.
exact H3.
apply H0.
exact H4.
assumption.
Defined.

Lemma chains_sup_correct: forall (F:Ensemble chains)
  (P:chain chains_ord F), let U := chains_sup_def F P in
    (forall S:chains, In F S -> chains_ord S U) /\
    (forall T:chains, (forall S:chains, In F S -> chains_ord S T) ->
      chains_ord U T).
Proof.
intros.
split.
intros.
unfold chains_ord.
unfold Included.
intros.
unfold U.
simpl.
constructor.
exists S.
auto.
intros.
unfold chains_ord.
unfold Included.
intros.
unfold U in H0.
simpl in H0.
destruct H0.
destruct H0.
destruct H0.
apply H in H0.
apply H0.
assumption.
Qed.

Definition chains_sup (F:Ensemble chains) (P:chain chains_ord F) :=
  let U := chains_sup_def F P in
  exist (fun U:chains =>
    (forall S:chains, In F S -> chains_ord S U) /\
    (forall T:chains, (forall S:chains, In F S -> chains_ord S T) ->
      chains_ord U T))
  (chains_sup_def F P) (chains_sup_correct F P).

Theorem ZornsLemma: exists x:T, maximal R x.
Proof.
pose proof (ZL' chains chains_ord chains_order chains_sup).

apply NNPP.
unfold maximal.
dintuition.
assert (forall x:T, ~ forall y:T, R x y -> x = y).
apply not_ex_all_not.
exact H0.
assert (forall x:T, exists y:T, ~ (R x y -> x = y)).
intro.
apply not_all_ex_not.
apply H1.
assert (forall x:T, exists y:T, R x y /\ x <> y).
intro.
pose proof (H2 x).
destruct H3.
apply imply_to_and in H3.
exists x0.
assumption.
clear H0 H1 H2.

assert (forall x:chains, exists y:chains,
  chains_ord x y /\ x <> y /\ forall z:chains, chains_ord x z ->
  chains_ord z y -> z = x \/ z = y).
intro.
destruct x.
pose proof (ub_of_chain x c).
destruct H0.
pose proof (H3 x0).
destruct H1.

pose (x' := Add x x1).
assert (chain R x').
unfold chain.
intros.
case H2.
case H4.
intros.
apply c.
assumption.
assumption.
intros.
destruct H5.
left.
apply ord_trans with x0.
apply H0.
assumption.
apply H1.
intros.
destruct H5.
case H4.
right.
apply ord_trans with x0.
apply H0.
assumption.
apply H1.
intros.
destruct H5.
left.
apply ord_refl.

exists (exist _ x' H2).
split.
unfold chains_ord.
simpl.
unfold Included.
intros.
constructor.
assumption.

split.
intuition.
injection H4.
intro.
assert (In x x1).
rewrite H1.
constructor 2.
auto with sets.
contradict H6.
apply ord_antisym.
assumption.
apply H0.
assumption.

intros.
destruct z.
unfold chains_ord in H4.
simpl in H4.
unfold chains_ord in H5.
simpl in H5.

case (classic (In x2 x1)).
right.
apply subset_eq_compatT.
apply Extensionality_Ensembles.
split.
assumption.
unfold Included.
intros.
case H7.
exact H4.
intros.
destruct H8.
assumption.

left.
apply subset_eq_compatT.
apply Extensionality_Ensembles.
split.
unfold Included.
intros.
assert (In x' x3).
apply H5.
assumption.
inversion H8.
assumption.
destruct H9.
contradiction H6.
assumption.

apply choice in H0.
destruct H0 as [f].
apply H.
intro.
apply exist with (f x).
apply H0.
Qed.

End ZL.

Arguments ZornsLemma {T}.

Require Import Quotients.

Section ZL_preorder.

Variable T:Type.
Variable R:relation T.
Hypothesis Rpreord: preorder R.
Hypothesis ub_of_chain: forall S:Ensemble T, chain R S ->
  exists x:T, forall y:T, In S y -> R y x.

Definition premaximal (x:T) : Prop :=
  forall y:T, R x y -> R y x.

Lemma ZornsLemmaForPreorders: exists x:T, premaximal x.
Proof.
pose (Requiv (x y:T) := R x y /\ R y x).
assert (equivalence Requiv).
constructor.
red; intros.
split; apply preord_refl; trivial.
red; intros.
destruct H.
destruct H0.
split; apply preord_trans with y; trivial.
red; intros.
destruct H.
split; trivial.

pose (Rquo := quotient Requiv).
let Hnew:=fresh"_H" in
  unshelve refine (let Hnew:=_ in
     let inducedR := induced_function2arg R H H Hnew in
     let inducedR_prop := induced_function2arg_correct R H H Hnew in _).
intros.
assert (True_rect (R a1 b1) = True_rect (R a2 b2)).
apply Extensionality_Ensembles; split; red; intros.
destruct x.
red in H2.
simpl in H2.
red; simpl.
apply preord_trans with a1; trivial.
apply H0.
apply preord_trans with b1; trivial.
apply H1.
destruct x.
red in H2; simpl in H2.
red; simpl.
apply preord_trans with a2; trivial.
apply H0.
apply preord_trans with b2; trivial.
apply H1.
assert (True_rect (R a1 b1) I = True_rect (R a2 b2) I).
rewrite H2; trivial.
simpl in H3.
assumption.
clearbody inducedR_prop.
fold inducedR in inducedR_prop.

assert (exists x:Rquo, maximal inducedR x).
apply ZornsLemma.
constructor.
red; intros xbar.
destruct (quotient_projection_surjective xbar) as [x []].
rewrite inducedR_prop.
apply preord_refl; trivial.
red; intros xbar ybar zbar ? ?.
destruct (quotient_projection_surjective xbar) as [x].
destruct H2.
destruct (quotient_projection_surjective ybar) as [y].
destruct H2.
destruct (quotient_projection_surjective zbar) as [z].
destruct H2.
rewrite inducedR_prop in H0, H1.
rewrite inducedR_prop.
apply preord_trans with y; trivial.
red; intros xbar ybar ? ?.
destruct (quotient_projection_surjective xbar) as [x].
destruct H2.
destruct (quotient_projection_surjective ybar) as [y].
destruct H2.
rewrite inducedR_prop in H0, H1.
unfold quotient_projection.
apply subset_eq_compatT.
apply R_impl_equality_of_equiv_class; trivial.
split; trivial.

intros Sbar ?.
pose (S := inverse_image (quotient_projection _) Sbar).
unshelve refine (let H1:=ub_of_chain S _ in _).
red; intros.
pose proof (H0 (quotient_projection _ x) (quotient_projection _ y)).
rewrite 2 inducedR_prop in H3.
destruct H1.
destruct H2.
apply H3; trivial.

destruct H1.
exists (quotient_projection _ x).
intros ybar ?.
destruct (quotient_projection_surjective ybar) as [y].
destruct H3.
rewrite inducedR_prop.
apply H1.
constructor; exact H2.

destruct H0 as [xbar].
destruct (quotient_projection_surjective xbar) as [x].
destruct H1.
exists x.
red; intros.
red in H0.
unshelve refine (let H2:=H0 (quotient_projection Requiv y) _ in _).
rewrite inducedR_prop.
assumption.
unfold quotient_projection in H2.
injection H2; intros.
assert (In (equiv_class Requiv x) y).
rewrite H3.
constructor; apply equiv_refl; trivial.
destruct H4.
apply H4.
Qed.

End ZL_preorder.

Arguments premaximal {T}.


Inductive I : Set :=
  | A : nat -> nat -> I
  | B : nat -> nat -> I.

Definition foo1 (x:I) : nat :=
  match x with
    | A a b | B a b => S b
  end.

Definition foo2 (x:I) : nat :=
  match x with
    | A _ b | B b _ => S b
  end.

Definition foo (x:I) : nat :=
  match x with
    | A a b | B b a => S b
  end.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal35.

Set Printing Depth 1000.
Definition lfind_eval  a z:=
mult z a.

Compute lfind_eval  (Succ Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Zero).

Compute lfind_eval  (Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Zero) (Zero).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Succ Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Succ Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Succ Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Zero).


Set Implicit Arguments.

Inductive typ : Set :=
  | typ_arrow : typ -> typ -> typ
  | typ_inter : typ -> typ -> typ.

Inductive Sub : typ -> typ -> Prop :=.

Fixpoint appl (t1 : typ) (t2 : typ) : Prop :=
  match t1 with
    | typ_arrow t3 t4 => t2 = t3
    | typ_inter t3 t4 => (appl t3 t2 /\ not (appl t4 t2)) \/ (not (appl t3 t2) /\ appl t4 t2)
  end.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Conjunction_A.

Coq < Goal forall e g:Prop, ((~e) /\ (~g)) -> (~e /\ ~g).
1 subgoal

  ============================
   forall e g : Prop, ~ e /\ ~ g -> ~ e /\ ~ g

Unnamed_thm < intros.
1 subgoal

  e : Prop
  g : Prop
  H : ~ e /\ ~ g
  ============================
   ~ e /\ ~ g

Unnamed_thm < exact H.
No more subgoals.

Unnamed_thm < Qed.
intros.
exact H.

Unnamed_thm is defined

Coq <

*)

Section Conjunction_A.
Goal forall e g:Prop, ((~e) /\ (~g)) -> (~e /\ ~g).
intros.
exact H.
Qed.


Require Import base_mods.

(* Definition of predicate and first order variable types, using Pred and Var
 constructors repectively. Assumes countably infinite for each. *)

Inductive predicate : Type :=
  Pred : nat -> predicate.

Lemma predicate_dec : forall (P Q : predicate), {P = Q} + {P <> Q}.
Proof.
  intros [p] [q]. destruct (Nat.eq_dec p q).
  subst. auto.
  right. intros H. inversion H. subst. auto.
Qed.

Lemma predicate_dec_l : forall {T : Type} P Q (x y : T),
    P = Q ->
    (if predicate_dec P Q then x else y) =  x.
Proof.
  intros T [Pn] [Qm] x y H.
  inversion H. subst.
  destruct (predicate_dec (Pred Qm) (Pred Qm)); firstorder.
Qed.

Lemma predicate_dec_r : forall {T : Type} P Q (x y : T),
    P <> Q ->
    (if predicate_dec P Q then x else y) =  y.
Proof.
  intros T [Pn] [Qm] x y H.
  destruct (predicate_dec (Pred Pn) (Pred Qm)); firstorder.
Qed.

Lemma predicate_dec_refl : forall {T : Type} P (a b : T),
    (if predicate_dec P P then a else b) = a.
Proof. intros. rewrite predicate_dec_l; firstorder. Qed.

Lemma Pred_neq : forall Pn Qm,
  Pred Pn <> Pred Qm -> Pn <> Qm.
Proof. intros xn ym H1 H2. subst. contradiction. Qed.

Lemma in_predicate_dec : forall (a : predicate) l, {In a l} + {~ In a l}.
Proof.
  intros. apply in_dec. apply predicate_dec.
Qed.

Lemma in_predicate_dec_l : forall {T : Type} (a : predicate) l (x y : T),
    In a l -> ((if in_predicate_dec a l then x else y) = x).
Proof.
  intros. destruct (in_predicate_dec a l) as [H2 | H2].
  auto. contradiction.
Qed.

Lemma in_predicate_dec_r : forall {T : Type} (a : predicate) l (x y : T),
    ~ In a l -> ( (if in_predicate_dec a l then x else y) = y).
Proof.
  intros. destruct (in_predicate_dec a l) as [H2 | H2].
  contradiction. auto.
Qed.

Inductive FOvariable : Type :=
  Var : nat -> FOvariable.

Lemma FOvariable_dec : forall (x y : FOvariable), {x = y} + {x <> y}.
Proof.
  intros [p] [q]. destruct (PeanoNat.Nat.eq_dec p q).
  subst. auto. right. intros H.
  inversion H. subst. auto.
Qed.

Lemma FOvariable_dec_l : forall {T : Type} z1 z2 (x y : T),
    z1 = z2 ->
    (if FOvariable_dec z1 z2 then x else y) =  x.
Proof.
  intros T z1 z2 x y H. subst.
  destruct (FOvariable_dec z2); firstorder.
Qed.

Lemma FOvariable_dec_r : forall {T : Type} P Q (x y : T),
    P <> Q ->
    (if FOvariable_dec P Q then x else y) =  y.
Proof.
  intros T z1 z2 x y H.
  destruct (FOvariable_dec z1 z2); firstorder.
Qed.

Lemma FOvariable_dec_refl : forall {T : Type} x (a b : T),
 (if FOvariable_dec x x then a else b) = a.
Proof. intros. rewrite FOvariable_dec_l; firstorder. Qed.

Lemma Var_neq : forall xn ym,
  Var xn <> Var ym -> xn <> ym.
Proof. intros xn ym H1 H2. subst. contradiction. Qed.

Lemma FOv_not : forall n m,
    n <> m <-> Var n <> Var m.
Proof.
  intros n m; split; intros H1 H2;
  inversion H2 as [H3]; subst; firstorder.
Qed.

(* Second order formula (precisely: monadic second order logic with
a single binary relation and equality over firstorder variables.) *)
Inductive SecOrder :=
    predSO : predicate -> FOvariable -> SecOrder
  | relatSO : FOvariable -> FOvariable -> SecOrder
  | eqFO : FOvariable -> FOvariable -> SecOrder
  | allFO : FOvariable -> SecOrder -> SecOrder
  | exFO : FOvariable -> SecOrder -> SecOrder
  | negSO : SecOrder -> SecOrder
  | conjSO : SecOrder -> SecOrder -> SecOrder
  | disjSO : SecOrder -> SecOrder -> SecOrder
  | implSO : SecOrder -> SecOrder -> SecOrder
  | allSO : predicate -> SecOrder -> SecOrder
  | exSO : predicate -> SecOrder -> SecOrder.

Notation "$ P" := (predSO P) (at level 1) : SO_scope.
Notation "x =FOv y" := (eqFO x y) (at level 2) : SO_scope.
Notation "SO~ α" := (negSO α) (at level 2) : SO_scope.
Notation "A SO∨ B" := (disjSO A B) (at level 15, right associativity) : SO_scope.
Notation "A SO∧ B" := (conjSO A B) (at level 15, right associativity) : SO_scope.
Notation "A SO→ B" := (implSO A B) (at level 16, right associativity) : SO_scope.

(* Given a conditional, return the antecedent. Don't care about other
   inputs. *)
Fixpoint calc_ante_SO alpha :=
  match alpha with
  | predSO _ _ => alpha
  | relatSO _ _ => alpha
  | eqFO _ _ => alpha
  | allFO x beta => alpha
  | exFO x beta => alpha
  | negSO beta => alpha
  | conjSO beta1 beta2 => alpha
  | disjSO beta1 beta2 => alpha
  | implSO beta1 beta2 => beta1
  | allSO Q beta => alpha
  | exSO Q beta => alpha
  end.

(* Given a conditional, returns the consequent. Don't care about other
   inputs. *)
Fixpoint calc_cons_SO alpha :=
  match alpha with
  | predSO _ _ => alpha
  | relatSO _ _ => alpha
  | eqFO _ _ => alpha
  | allFO x beta => alpha
  | exFO x beta => alpha
  | negSO beta => alpha
  | conjSO beta1 beta2 => alpha
  | disjSO beta1 beta2 => alpha
  | implSO beta1 beta2 => beta2
  | allSO Q beta => alpha
  | exSO Q beta => alpha
  end.


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

  I'll need to build partial functions from list sets, I would say.

*)

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

Set Implicit Arguments.

(* Local Open Scope pfun_scope. jrw ? *)

Section PFun.

Variable D : Type.
Variable C : Type.

Hypothesis D_eq_dec : forall x y: D, {x = y} + {x <> y}.
Hypothesis C_eq_dec : forall x y: C, {x = y} + {x <> y}.

Definition pfun := list (D * C).

Definition empty_pfun : pfun := nil.

Fixpoint pfun_add (f:pfun) (dc: D * C) : pfun :=
match dc with
 | (d,c) =>
    match f with
      | nil => dc :: nil
      | (d',c') :: f' =>
        match D_eq_dec d d' with
          | left _ => dc :: f'
          | right _ => (d',c') :: pfun_add f' dc
        end
    end
end.

Arguments pfun_add _ [dc].

(* Not sure what to do with pairing, I think leave it ()
 Notation " x |-> f "  := (pfun_add f) (at level 70, y at next level).
*)

Infix "+>" := pfun_add (at level 61, right associativity).

Fixpoint pfun_in_dom (d:D) (f:pfun) : bool :=
    match f with
    | nil => false
    | (d',c) :: f' =>
        match D_eq_dec d d' with
        | left _ => true
        | right _ => pfun_in_dom d f'
        end
    end.

Arguments pfun_in_dom [d] _.

Fixpoint pfun_remove (f:pfun) (d:D) : pfun :=
    match f with
    | nil => empty_pfun
    | (d',c) :: f' =>
        match D_eq_dec d d' with
        | left _ => f'
        | right _ => (d',c) :: pfun_remove f' d
        end
    end.

Arguments pfun_remove _ [d] .

Fixpoint pfun_get (f:pfun) (d:D) : option C :=
    match f with
    | nil => None
    | (d',c) :: f' =>
        match D_eq_dec d d' with
        | left _ => Some c
        | right _ => pfun_get f' d
        end
    end.

(*

Theorem nil_cons : forall (x: D * C) (l:pfun), [] <> (x +> l).

Lemma pfun_extensionality :
  forall (D C : Type) (f g : pfun) ,
    (forall d : D, (pfun_get f d) = pfun_get g d) ->
    f = g.
*)

Lemma pfun_eq_dec :
  (forall (d d': D), {d = d'} + {d <> d'}) ->
  (forall (c c': C), {c = c'} + {c <> c'}) ->
  forall x y: pfun, {x = y} + {x <> y}.
Admitted.

Check pfun_eq_dec.

End PFun.

Unset Implicit Arguments.


(* Andrew W. Appel and Stephen Yi-Hsien Lin,
    May 2013, October 2013, March 2014 *)

Require Recdef.
Require Import Bitoychain.sublist.
Require Import Bitoychain.Integers.
Require Import Bitoychain.Coqlib.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import List.
Require Import Bitoychain.general_lemmas.

(* THIS BLOCK OF STUFF is not needed to define SHA256,
  but is useful for reasoning about it *)
Definition LBLOCKz : Z := 16. (* length of a block, in 32-bit integers *)
Definition WORD : Z := 4.  (* length of a word, in bytes *)
Definition CBLOCKz : Z := (LBLOCKz * WORD)%Z. (* length of a block, in characters *)
Definition hi_part (z: Z) := Int.repr (z / Int.modulus).
Definition lo_part (z: Z) := Int.repr z.

Fixpoint little_endian_integer (contents: list int) : int :=
 match contents with
 | nil => Int.zero
 | c::cr => Int.or (Int.shl (little_endian_integer cr) (Int.repr 8)) c
 end.
Definition big_endian_integer (contents: list int) : int :=
   little_endian_integer (rev contents).
(* END OF "THIS BLOCK OF STUFF" *)

Import ListNotations.

(*
Lemma skipn_length:
  forall {A} n (al: list A),
    (length al >= n)%nat ->
    (length (skipn n al) = length al - n)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 apply IHn. omega.
Qed.
*)

(* PREPROCESSING: CONVERTING STRINGS TO PADDED MESSAGE BLOCKS *)

(*converting a string to a list of Z *)
Fixpoint str_to_Z (str : string) : list Z :=
  match str with
    |EmptyString => nil
    |String c s => Z.of_N (N_of_ascii c) :: str_to_Z s
    end.

Definition generate_and_pad msg :=
  let n := Zlength msg in
   Zlist_to_intlist (msg ++ [128%Z]
                ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0)
           ++ [Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)].

(*ROUND FUNCTION*)

(*hardcoding the constants, first 32 bits of the fractional parts of the cube roots of the first 64 prime numbers*)
Definition K256 := map Int.repr
  [1116352408 ; 1899447441; 3049323471; 3921009573;
   961987163   ; 1508970993; 2453635748; 2870763221;
   3624381080; 310598401  ; 607225278  ; 1426881987;
   1925078388; 2162078206; 2614888103; 3248222580;
   3835390401; 4022224774; 264347078  ; 604807628;
   770255983  ; 1249150122; 1555081692; 1996064986;
   2554220882; 2821834349; 2952996808; 3210313671;
   3336571891; 3584528711; 113926993  ; 338241895;
   666307205  ; 773529912  ; 1294757372; 1396182291;
   1695183700; 1986661051; 2177026350; 2456956037;
   2730485921; 2820302411; 3259730800; 3345764771;
   3516065817; 3600352804; 4094571909; 275423344;
   430227734  ; 506948616  ; 659060556  ; 883997877;
   958139571  ; 1322822218; 1537002063; 1747873779;
   1955562222; 2024104815; 2227730452; 2361852424;
   2428436474; 2756734187; 3204031479; 3329325298].

(*functions used for round function*)
Definition Ch (x y z : int) : int :=
  Int.xor (Int.and x y) (Int.and (Int.not x) z).

Definition Maj (x y z : int) : int :=
  Int.xor (Int.xor (Int.and x z) (Int.and y z) ) (Int.and x y).

Definition Rotr b x := Int.ror x (Int.repr b).

Definition Sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 2 x) (Rotr 13 x)) (Rotr 22 x).
Definition Sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 6 x) (Rotr 11 x)) (Rotr 25 x).
Definition sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 7 x) (Rotr 18 x)) (Shr 3 x).
Definition sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 17 x) (Rotr 19 x)) (Shr 10 x).

(* word function *)
Function W (M: Z -> int) (t: Z) {measure Z.to_nat t} : int :=
  if zlt t 16
  then M t
  else  (Int.add (Int.add (sigma_1 (W M (t-2))) (W M (t-7)))
               (Int.add (sigma_0 (W M (t-15))) (W M (t-16)))).
Proof.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
Qed.

(*registers that represent intermediate and final hash values*)
Definition registers := list int.

(*initializing the values of registers, first thirty-two bits of the fractional
    parts of the square roots of the first eight prime numbers*)
Definition init_registers : registers :=
  map Int.repr  [1779033703; 3144134277; 1013904242; 2773480762;
                        1359893119; 2600822924; 528734635; 1541459225].

Definition nthi (il: list int) (t: Z) := nth (Z.to_nat t) il Int.zero.

Definition rnd_function (x : registers) (k : int) (w : int) : registers:=
  match x with
  |  [a; b; c; d; e; f; g; h] =>
     let T1 := Int.add (Int.add (Int.add (Int.add h (Sigma_1 e)) (Ch e f g)) k) w in
     let T2 := Int.add (Sigma_0 a) (Maj a b c) in
       [Int.add T1 T2; a; b; c; Int.add d T1; e; f; g]
  | _ => nil  (* impossible *)
  end.

Function Round  (regs: registers) (M: Z ->int) (t: Z)
        {measure (fun t => Z.to_nat(t+1)) t} : registers :=
 if zlt t 0 then regs
 else rnd_function (Round regs M (t-1)) (nthi K256 t) (W M t).
Proof. intros; apply Z2Nat.inj_lt; omega.
Qed.

Definition hash_block (r: registers) (block: list int) : registers :=
      map2 Int.add r (Round r (nthi block) 63).

Function hash_blocks (r: registers) (msg: list int) {measure length msg} : registers :=
  match msg with
  | nil => r
  | _ => hash_blocks (hash_block r (firstn 16 msg)) (skipn 16 msg)
  end.
Proof. intros.
 destruct (lt_dec (length msg) 16).
 rewrite skipn_length_short. simpl; omega. subst; simpl in *; omega.
 rewrite <- teq; auto.
 rewrite skipn_length. simpl; omega.
Qed.

Definition SHA_256 (str : list Z) : list Z :=
    intlist_to_Zlist (hash_blocks init_registers (generate_and_pad str)).


(*** ************************ ***)
(*** TOWERS OF HANOI - EXTRAS ***)
(*** ************************ ***)

(* James Power * James.Power@May.ie * http://www.cs.may.ie/~jpower/ *)
(* Dept. of Computer Science, NUI Maynooth, Co. Kildare, Ireland.   *)

(* This file is part of the Towers of Hanoi in ILL example.
 * Here we define some auxiliary lemmas to help "clean up" the
 * main proof - they mostly relate to manipulating the conjunction
 * of (three) linear predicates that represents the state
 * The lemmas are:
 *   S23/Swap23: Used for MOVE n-1 discs from peg P1 to peg P2
 *   Lose2 :     Used when we TXFR 1 disc from peg P1 to peg P3
 *   S21/Swap21: Used for MOVE n-1 discs from peg P2 to peg P3
 *)

Require Export extraLL.

Remark S23
  (P1 P2 P3:ILinProp): ([P1***P2***P3] |- P1***P3***P2).
Proof.
intros.
linsplit.
leftapply TimesComm; apply Identity.
Qed.

Lemma Swap23
  (P1 P2 P3 C1 C2 C3:ILinProp):
  ([P1***P3***P2] |- C1***C3***C2) -> ([P1***P2***P3] |- C1***C2***C3).
Proof.
intros.
lincut (P1***P3***P2). apply S23.
lincut (C1***C3***C2); apply S23.
Qed.

Lemma Lose2
  (P1 P2 P3 C1 C3:ILinProp):
  ([P1***P3] |- C1***C3) -> ([P1***P2***P3] |- C1***P2***C3).
Proof.
intros.
leftapply Swap23.
leftapply TimesAssocR. apply RTimesAssocR.
linsplit. assumption.
Qed.

Remark S21
  (P1 P2 P3:ILinProp): ([P1***P2***P3] |- P2***P1***P3).
Proof.
intros.
leftapply TimesComm. leftapply TimesAssocL. linsplit.
leftapply TimesComm. apply Identity.
Qed.

Lemma Swap21
  (P1 P2 P3 C1 C2 C3:ILinProp):
  ([P2***P1***P3] |- C2***C1***C3) -> ([P1***P2***P3] |- C1***C2***C3).
Proof.
intros.
lincut (P2***P1***P3).
apply S21.
lincut (C2***C1***C3); apply S21.
Qed.


(* Game Of Life
  Ty Dang, Li-Chang Wang, Sung-Min Park
*)

Extraction Language Haskell.

(* Some definitions and notations that help *)
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Notation "x :: l" := (cons x l) (at level 60, right associativity).

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Definition blt_nat (n m : nat) : bool :=

  match beq_nat n m with
    | true => false
    | false => ble_nat n m
  end.

(* A mark on the board where each cell can be dead or alive *)
Inductive mark : Set :=
  | alive : mark
  | dead : mark.

(* A cell represented on a 4x4 grid *)
Inductive cell : Set :=
  | C00: cell
  | C01: cell
  | C02: cell
  | C03: cell
  | C10: cell
  | C11: cell
  | C12: cell
  | C13: cell
  | C20: cell
  | C21: cell
  | C22: cell
  | C23: cell
  | C30: cell
  | C31: cell
  | C32: cell
  | C33: cell.

(* A board of size 4x4 made of marks *)
Inductive board :=
  mk_board: mark -> mark -> mark -> mark ->
            mark -> mark -> mark -> mark ->
            mark -> mark -> mark -> mark ->
            mark -> mark -> mark -> mark -> board.

(* Place a mark at the cell location for the given board and returns a new board *)
Definition place (c: cell) (m : mark) (b : board) : board :=
  match b with
  | mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33 =>
      match c with
      | C00 => mk_board m b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C01 => mk_board b00 m b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C02 => mk_board b00 b01 m b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C03 => mk_board b00 b01 b02 m b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C10 => mk_board b00 b01 b02 b03 m b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C11 => mk_board b00 b01 b02 b03 b10 m b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C12 => mk_board b00 b01 b02 b03 b10 b11 m b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C13 => mk_board b00 b01 b02 b03 b10 b11 b12 m b20 b21 b22 b23 b30 b31 b32 b33
      | C20 => mk_board b00 b01 b02 b03 b10 b11 b12 b13 m b21 b22 b23 b30 b31 b32 b33
      | C21 => mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 m b22 b23 b30 b31 b32 b33
      | C22 => mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 m b23 b30 b31 b32 b33
      | C23 => mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 m b30 b31 b32 b33
      | C30 => mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 m b31 b32 b33
      | C31 => mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 m b32 b33
      | C32 => mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 m b33
      | C33 => mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 m
      end
  end.

(* Initialize the board given a list of cells to mark as alive *)
Fixpoint initialize (b : board) (l : list cell) : board :=
  match l with
  | nil => b
  | cons h t => initialize (place h alive b) t
  end.

(* Get the mark value at the cell location on the given board *)
Definition get (b: board) (c: cell) : mark :=
  match b with
  | mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33 =>
      match c with
      | C00 => b00
      | C01 => b01
      | C02 => b02
      | C03 => b03
      | C10 => b10
      | C11 => b11
      | C12 => b12
      | C13 => b13
      | C20 => b20
      | C21 => b21
      | C22 => b22
      | C23 => b23
      | C30 => b30
      | C31 => b31
      | C32 => b32
      | C33 => b33
      end
  end.

(* Return the number of alive neighbors around the given cell. The neighbors list is passed into the function *)
Fixpoint rec_num_nei (b:board) (l: list cell) (c: cell) : nat :=
  match l with
  | nil => 0
  | h :: t => match (get b h) with
              | alive => S (rec_num_nei b t c)
              | dead => (rec_num_nei b t c)
              end
  end.

(* Apply the Game of Life rules on the given cell and return the new board *)
Definition apply_rules (b_old: board) (b_new: board) (c: cell) : board :=
  match b_old with
  | mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33 =>
      match c with
      | C00 => if( beq_nat (rec_num_nei b_old [C01; C10; C11] c) 0) then b_new else (place c alive b_new)
      | C01 => if( beq_nat (rec_num_nei b_old [C00; C02; C10; C11; C12] c) 0) then b_new else (place c alive b_new)
      | C02 => if( beq_nat (rec_num_nei b_old [C01; C03; C11; C12; C13] c) 0) then b_new else (place c alive b_new)
      | C03 => if( beq_nat (rec_num_nei b_old [C02; C12; C13] c) 0) then b_new else (place c alive b_new)
      | C10 => if( beq_nat (rec_num_nei b_old [C00; C01; C11; C20; C21] c) 0) then b_new else (place c alive b_new)
      | C11 => if( beq_nat (rec_num_nei b_old [C00; C01; C02; C10; C12; C20; C21; C22] c) 0) then b_new else (place c alive b_new)
      | C12 => if( beq_nat (rec_num_nei b_old [C01; C02; C03; C11; C13; C21; C22; C23] c) 0) then b_new else (place c alive b_new)
      | C13 => if( beq_nat (rec_num_nei b_old [C02; C03; C12; C22; C23] c) 0) then b_new else (place c alive b_new)
      | C20 => if( beq_nat (rec_num_nei b_old [C10; C11; C21; C30; C31] c) 0) then b_new else (place c alive b_new)
      | C21 => if( beq_nat (rec_num_nei b_old [C10; C11; C12; C20; C22; C30; C31; C32] c) 0) then b_new else (place c alive b_new)
      | C22 => if( beq_nat (rec_num_nei b_old [C11; C12; C13; C21; C23; C31; C32; C33] c) 0) then b_new else (place c alive b_new)
      | C23 => if( beq_nat (rec_num_nei b_old [C12; C13; C22; C32; C33] c) 0) then b_new else (place c alive b_new)
      | C30 => if( beq_nat (rec_num_nei b_old [C20; C21; C31]  c) 0) then b_new else (place c alive b_new)
      | C31 => if( beq_nat (rec_num_nei b_old [C20; C21; C22; C30; C32] c) 0) then b_new else (place c alive b_new)
      | C32 => if( beq_nat (rec_num_nei b_old [C21; C22; C23; C31; C33] c) 0) then b_new else (place c alive b_new)
      | C33 => if( beq_nat (rec_num_nei b_old [C22; C23; C32] c) 0) then b_new else (place c alive b_new)
      end
  end.

(* This would not compile... too big?
Definition apply_rules (b_old: board) (b_new: board) (c: cell) : board :=
  match c, get b_old c with
    | C00, alive => if( blt_nat (rec_num_nei b_old [C01; C10; C11] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C01; C10; C11] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C01; C10; C11] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C01; C10; C11] c) 4) then b_new else (place c dead b_new)
    | C00, dead => if( beq_nat (rec_num_nei b_old [C01; C10; C11] c) 3) then (place c alive b_new) else b_new
    | C01, alive => if( blt_nat (rec_num_nei b_old [C00; C02; C10; C11; C12] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C00; C02; C10; C11; C12] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C00; C02; C10; C11; C12] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C00; C02; C10; C11; C12] c) 4) then b_new else (place c dead b_new)
    | C01, dead => if( beq_nat (rec_num_nei b_old [C00; C02; C10; C11; C12] c) 3) then (place c alive b_new) else b_new
    | C02, alive => if( blt_nat (rec_num_nei b_old [C01; C03; C11; C12; C13] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C01; C03; C11; C12; C13] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C01; C03; C11; C12; C13] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C01; C03; C11; C12; C13] c) 4) then b_new else (place c dead b_new)
    | C02, dead => if( beq_nat (rec_num_nei b_old [C01; C03; C11; C12; C13] c) 3) then (place c alive b_new) else b_new
    | C03, alive => if( blt_nat (rec_num_nei b_old [C02; C12; C13] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C02; C12; C13] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C02; C12; C13] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C02; C12; C13] c) 4) then b_new else (place c dead b_new)
    | C03, dead => if( beq_nat (rec_num_nei b_old [C02; C12; C13] c) 3) then (place c alive b_new) else b_new
    | C10, alive => if( blt_nat (rec_num_nei b_old [C00; C01; C11; C20; C21] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C00; C01; C11; C20; C21] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C00; C01; C11; C20; C21] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C00; C01; C11; C20; C21] c) 4) then b_new else (place c dead b_new)
    | C10, dead => if( beq_nat (rec_num_nei b_old [C00; C01; C11; C20; C21] c) 3) then (place c alive b_new) else b_new
    | C11, alive => if( blt_nat (rec_num_nei b_old [C00; C01; C02; C10; C12; C20; C21; C22] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C00; C01; C02; C10; C12; C20; C21; C22] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C00; C01; C02; C10; C12; C20; C21; C22] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C00; C01; C02; C10; C12; C20; C21; C22] c) 4) then b_new else (place c dead b_new)
    | C11, dead => if( beq_nat (rec_num_nei b_old [C00; C01; C02; C10; C12; C20; C21; C22] c) 3) then (place c alive b_new) else b_new
    | C12, alive => if( blt_nat (rec_num_nei b_old [C01; C02; C03; C11; C13; C21; C22; C23] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C01; C02; C03; C11; C13; C21; C22; C23] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C01; C02; C03; C11; C13; C21; C22; C23] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C01; C02; C03; C11; C13; C21; C22; C23] c) 4) then b_new else (place c dead b_new)
    | C12, dead => if( beq_nat (rec_num_nei b_old [C01; C02; C03; C11; C13; C21; C22; C23] c) 3) then (place c alive b_new) else b_new
    | C13, alive => if( blt_nat (rec_num_nei b_old [C02; C03; C12; C22; C23] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C02; C03; C12; C22; C23] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C02; C03; C12; C22; C23] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C02; C03; C12; C22; C23] c) 4) then b_new else (place c dead b_new)
    | C13, dead => if( beq_nat (rec_num_nei b_old [C02; C03; C12; C22; C23] c) 3) then (place c alive b_new) else b_new
    | C20, alive => if( blt_nat (rec_num_nei b_old [C10; C11; C21; C30; C31] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C10; C11; C21; C30; C31] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C10; C11; C21; C30; C31] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C10; C11; C21; C30; C31] c) 4) then b_new else (place c dead b_new)
    | C20, dead => if( beq_nat (rec_num_nei b_old [C10; C11; C21; C30; C31] c) 3) then (place c alive b_new) else b_new
    | C21, alive => if( blt_nat (rec_num_nei b_old [C10; C11; C12; C20; C22; C30; C31; C32] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C10; C11; C12; C20; C22; C30; C31; C32] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C10; C11; C12; C20; C22; C30; C31; C32] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C10; C11; C12; C20; C22; C30; C31; C32] c) 4) then b_new else (place c dead b_new)
    | C21, dead => if( beq_nat (rec_num_nei b_old [C10; C11; C12; C20; C22; C30; C31; C32] c) 3) then (place c alive b_new) else b_new
    | C22, alive => if( blt_nat (rec_num_nei b_old [C11; C12; C13; C21; C23; C31; C32; C33] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C11; C12; C13; C21; C23; C31; C32; C33] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C11; C12; C13; C21; C23; C31; C32; C33] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C11; C12; C13; C21; C23; C31; C32; C33] c) 4) then b_new else (place c dead b_new)
    | C22, dead => if( beq_nat (rec_num_nei b_old [C11; C12; C13; C21; C23; C31; C32; C33] c) 3) then (place c alive b_new) else b_new
    | C23, alive => if( blt_nat (rec_num_nei b_old [C12; C13; C22; C32; C33] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C12; C13; C22; C32; C33] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C12; C13; C22; C32; C33] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C12; C13; C22; C32; C33] c) 4) then b_new else (place c dead b_new)
    | C23, dead => if( beq_nat (rec_num_nei b_old [C12; C13; C22; C32; C33] c) 3) then (place c alive b_new) else b_new
    | C30, alive => if( blt_nat (rec_num_nei b_old [C20; C21; C31] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C20; C21; C31] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C20; C21; C31] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C20; C21; C31] c) 4) then b_new else (place c dead b_new)
    | C30, dead => if( beq_nat (rec_num_nei b_old [C20; C21; C31] c) 3) then (place c alive b_new) else b_new
    | C31, alive => if( blt_nat (rec_num_nei b_old [C20; C21; C22; C30; C32] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C20; C21; C22; C30; C32] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C20; C21; C22; C30; C32] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C20; C21; C22; C30; C32] c) 4) then b_new else (place c dead b_new)
    | C31, dead => if( beq_nat (rec_num_nei b_old [C20; C21; C22; C30; C32] c) 3) then (place c alive b_new) else b_new
    | C32, alive => if( blt_nat (rec_num_nei b_old [C21; C22; C23; C31; C33] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C21; C22; C23; C31; C33] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C21; C22; C23; C31; C33] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C21; C22; C23; C31; C33] c) 4) then b_new else (place c dead b_new)
    | C32, dead => if( beq_nat (rec_num_nei b_old [C21; C22; C23; C31; C33] c) 3) then (place c alive b_new) else b_new
    | C33, alive => if( blt_nat (rec_num_nei b_old [C22; C23; C32] c) 2) then (place c dead b_new) else
                    if( beq_nat (rec_num_nei b_old [C22; C23; C32] c) 2) then b_new else
                    if( beq_nat (rec_num_nei b_old [C22; C23; C32] c) 3) then b_new else
                    if( blt_nat (rec_num_nei b_old [C22; C23; C32] c) 4) then b_new else (place c dead b_new)
    | C33, dead => if( beq_nat (rec_num_nei b_old [C22; C23; C32] c) 3) then (place c alive b_new) else b_new
  end.
*)

(* Update the board by applying the game of life rules on each cell *)
Fixpoint update (b_old: board)(b_new: board)(c: list cell): board :=
  match c with
  | nil => b_new
  | h :: t => update b_old (apply_rules b_old b_new h) t
  end.

Definition emptyboard := mk_board dead dead dead dead
                           dead dead dead dead
                           dead dead dead dead
                           dead dead dead dead.
Definition fullboard := mk_board alive alive alive alive
                                 alive alive alive alive
                                 alive alive alive alive
                                 alive alive alive alive.
Definition all_cells := [C00; C01; C02; C03; C10; C11; C12; C13; C20; C21; C22; C23; C30; C31; C32; C33].
Definition board1 := mk_board dead alive dead dead
                              dead dead dead dead
                              dead dead dead dead
                              dead dead dead dead.
Definition board2 := mk_board alive alive alive dead
                              alive alive alive dead
                              dead dead dead dead
                              dead dead dead dead.
Definition board3 := mk_board alive alive alive alive
                              alive alive alive alive
                              alive alive alive alive
                              dead dead dead dead.

(* Play the game for "num" iterations *)
Fixpoint do_play_game (b: board) (num: nat) : board :=
  match num with
  | O => b
  | S n => do_play_game (update b b all_cells) n
  end.

(* Start the game passing in a list of alive cells and a number of iterations *)
Definition play_game (l: list cell) (n: nat) : board :=
  do_play_game (initialize emptyboard l) n.

Compute play_game [C01;C10;C11] 0.

(* Some proofs *)
Theorem emptyboard_no_nei_c00 : rec_num_nei emptyboard [C01; C10; C11] C00 = 0.
Proof.
simpl.
reflexivity.
Qed.

Theorem emptyboard_no_change_c00 : apply_rules emptyboard emptyboard C00 = emptyboard.
Proof.
simpl.
reflexivity.
Qed.

Theorem emptyboard_no_change_all : forall c:cell, apply_rules emptyboard emptyboard c = emptyboard.
Proof.
simpl.
destruct c.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
reflexivity.
Qed.

Theorem emptyboard_no_change_all_do_play_game : forall n:nat, do_play_game emptyboard n = emptyboard.
Proof.
simpl.
induction n.
simpl.
reflexivity.
simpl.
apply IHn.
Qed.

Theorem fullboard_is_fullboard : forall n:nat, do_play_game fullboard n = fullboard.
Proof.
simpl.
induction n.
simpl.
reflexivity.
simpl.
apply IHn.
Qed.

(* Note, these last few theorems are in relation to board1 to prove "fullboard-ness" *)
Theorem board3_onestep_full : do_play_game board3 1 = fullboard.
Proof.
simpl.
reflexivity.
Qed.

Theorem board2_twostep_full : do_play_game board2 2 = fullboard.
Proof.
simpl.
reflexivity.
Qed.

Theorem board1_threestep_full : do_play_game board1 3 = fullboard.
Proof.
simpl.
reflexivity.
Qed.

Theorem full_by_3_board1 : forall (n:nat), n > 2 -> do_play_game board1 n = fullboard.
Proof.
intros.
induction n.
inversion H.
induction n.
inversion H.
inversion H1.
induction n.
inversion H.
inversion H1.
inversion H3.
induction n.
apply board1_threestep_full.
apply fullboard_is_fullboard.
Qed.

(* These were other attempts at doing a "full by 3" proof *)
Theorem full_by_3_board1' : forall (n:nat), n > 2 -> do_play_game board1 n =
  mk_board alive alive alive alive
           alive alive alive alive
           alive alive alive alive
           alive alive alive alive.
Proof.
intros.
induction n.
inversion H.
simpl.
induction n.
simpl.
rewrite <- IHn.
inversion H.
inversion H1.
inversion H.
inversion H1.
simpl.
rewrite <- IHn0.
inversion H.
simpl.
rewrite <- IHn0.
simpl.
rewrite <- H1.
simpl.
reflexivity.
Abort.

Theorem full_by_3' : forall (n:nat) (lc: list cell), n > 2 -> length lc > 0 -> play_game lc n =
  mk_board alive alive alive alive
           alive alive alive alive
           alive alive alive alive
           alive alive alive alive.
Proof.
intros.
induction n.
inversion H.
Abort.

(* Extract to Haskell *)
Extraction "golhask" play_game.
Extract Inductive mark => "mark" [ "alive" "dead" ].
Extract Inductive cell => "cell" [ "C00" "C01" "C02" "C03"
                                   "C10" "C11" "C12" "C13"
                                   "C20" "C21" "C22" "C23"
                                   "C30" "C31" "C32" "C33" ].
Extract Inductive board => "board" [ "mark -> mark -> mark -> mark ->
                                      mark -> mark -> mark -> mark ->
                                      mark -> mark -> mark -> mark ->
                                      mark -> mark -> mark -> mark" ].

(* Some testing *)

Compute place C00 alive emptyboard.
Compute place C23 alive emptyboard.

Example mylist := cons C00 (cons C01(cons C02 nil)).
Compute initialize emptyboard mylist.

Definition list10 := [C00].
Compute initialize emptyboard list10.

Compute update (initialize emptyboard list10) (initialize emptyboard list10)  all_cells.

Definition list_fancy := [C00; C01; C02; C10; C12; C20; C21; C22].
Example test_list_fancy : rec_num_nei emptyboard list_fancy C11 = 0.
Proof. reflexivity. Qed.

Definition b10 := mk_board alive alive alive dead alive alive alive dead alive alive alive dead dead dead dead dead.
Example test_b10 : rec_num_nei b10 list_fancy C11 = 8.
Proof. reflexivity. Qed.

(* An attempt at making the game CoInductive with an infinite while loop *)
(*
CoInductive board' :=
  mk_board': mark -> mark -> mark -> mark ->
            mark -> mark -> mark -> mark ->
            mark -> mark -> mark -> mark ->
            mark -> mark -> mark -> mark -> board'.

Definition place' (c: cell) (m : mark) (b : board') : board' :=
  match b with
  | mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33 =>
      match c with
      | C00 => mk_board' m b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C01 => mk_board' b00 m b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C02 => mk_board' b00 b01 m b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C03 => mk_board' b00 b01 b02 m b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C10 => mk_board' b00 b01 b02 b03 m b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C11 => mk_board' b00 b01 b02 b03 b10 m b12 b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C12 => mk_board' b00 b01 b02 b03 b10 b11 m b13 b20 b21 b22 b23 b30 b31 b32 b33
      | C13 => mk_board' b00 b01 b02 b03 b10 b11 b12 m b20 b21 b22 b23 b30 b31 b32 b33
      | C20 => mk_board' b00 b01 b02 b03 b10 b11 b12 b13 m b21 b22 b23 b30 b31 b32 b33
      | C21 => mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 m b22 b23 b30 b31 b32 b33
      | C22 => mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 m b23 b30 b31 b32 b33
      | C23 => mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 m b30 b31 b32 b33
      | C30 => mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 m b31 b32 b33
      | C31 => mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 m b32 b33
      | C32 => mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 m b33
      | C33 => mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 m
      end
  end.

Definition get' (b: board') (c: cell) : mark :=
  match b with
  | mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33 =>
      match c with
      | C00 => b00
      | C01 => b01
      | C02 => b02
      | C03 => b03
      | C10 => b10
      | C11 => b11
      | C12 => b12
      | C13 => b13
      | C20 => b20
      | C21 => b21
      | C22 => b22
      | C23 => b23
      | C30 => b30
      | C31 => b31
      | C32 => b32
      | C33 => b33
      end
  end.

Fixpoint rec_num_nei' (b:board') (l: list cell) (c: cell) : nat :=
  match l with
  | nil => 0
  | h :: t => match (get' b h) with
              | alive => S (rec_num_nei' b t c)
              | dead => (rec_num_nei' b t c)
              end
  end.

Definition apply_rules' (b_old: board') (b_new: board') (c: cell) : board' :=
  match b_old with
  | mk_board' b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33 =>
      match c with
      | C00 => if( beq_nat (rec_num_nei' b_old [C01; C10; C11] c) 0) then b_new else (place' c alive b_new)
      | C01 => if( beq_nat (rec_num_nei' b_old [C00; C02; C10; C11; C12] c) 0) then b_new else (place' c alive b_new)
      | C02 => if( beq_nat (rec_num_nei' b_old [C01; C03; C11; C12; C13] c) 0) then b_new else (place' c alive b_new)
      | C03 => if( beq_nat (rec_num_nei' b_old [C02; C12; C13] c) 0) then b_new else (place' c alive b_new)
      | C10 => if( beq_nat (rec_num_nei' b_old [C00; C01; C11; C20; C21] c) 0) then b_new else (place' c alive b_new)
      | C11 => if( beq_nat (rec_num_nei' b_old [C00; C01; C02; C10; C12; C20; C21; C22] c) 0) then b_new else (place' c alive b_new)
      | C12 => if( beq_nat (rec_num_nei' b_old [C01; C02; C03; C11; C13; C21; C22; C23] c) 0) then b_new else (place' c alive b_new)
      | C13 => if( beq_nat (rec_num_nei' b_old [C02; C03; C12; C22; C23] c) 0) then b_new else (place' c alive b_new)
      | C20 => if( beq_nat (rec_num_nei' b_old [C10; C11; C21; C30; C31] c) 0) then b_new else (place' c alive b_new)
      | C21 => if( beq_nat (rec_num_nei' b_old [C10; C11; C12; C20; C22; C30; C31; C32] c) 0) then b_new else (place' c alive b_new)
      | C22 => if( beq_nat (rec_num_nei' b_old [C11; C12; C13; C21; C23; C31; C32; C33] c) 0) then b_new else (place' c alive b_new)
      | C23 => if( beq_nat (rec_num_nei' b_old [C12; C13; C22; C32; C33] c) 0) then b_new else (place' c alive b_new)
      | C30 => if( beq_nat (rec_num_nei' b_old [C20; C21; C31]  c) 0) then b_new else (place' c alive b_new)
      | C31 => if( beq_nat (rec_num_nei' b_old [C20; C21; C22; C30; C32] c) 0) then b_new else (place' c alive b_new)
      | C32 => if( beq_nat (rec_num_nei' b_old [C21; C22; C23; C31; C33] c) 0) then b_new else (place' c alive b_new)
      | C33 => if( beq_nat (rec_num_nei' b_old [C22; C23; C32] c) 0) then b_new else (place' c alive b_new)
      end
  end.

Fixpoint update' (b_old: board')(b_new: board')(c: list cell): board' :=
  match c with
  | nil => b_new
  | h :: t => update' b_old (apply_rules' b_old b_new h) t
  end.

CoFixpoint do_play_game (b: board') : board' :=
  do_play_game (update' b b all_cells).

Definition play_game (

Compute play_game list10
*)

(* functions that may be used later *)
(*
Definition spread_rule (b: board) (c: cell) : board :=
  match (get b c) with
  | alive => b
  | dead => match c with
                  | C00 => if( beq_nat (rec_num_nei b [C01; C10; C11] c) 0) then b else (place c alive b)
                  | C01 => b01
                  | C02 => b02
                  | C03 => b03
                  | C10 => b10
                  | C11 => b11
                  | C12 => b12
                  | C13 => b13
                  | C20 => b20
                  | C21 => b21
                  | C22 => b22
                  | C23 => b23
                  | C30 => b30
                  | C31 => b31
                  | C32 => b32
                  | C33 => b33
                  end
  end.
*)

(*
Definition num_neighbors (b: board) (c: cell) : nat :=
match b with
  | mk_board b00 b01 b02 b03 b10 b11 b12 b13 b20 b21 b22 b23 b30 b31 b32 b33 =>
      match c with
      | C00 => rec_num_nei b
      | C01 => b01
      | C02 => b02
      | C03 => b03
      | C10 => b10
      | C11 => b11
      | C12 => b12
      | C13 => b13
      | C20 => b20
      | C21 => b21
      | C22 => b22
      | C23 => b23
      | C30 => b30
      | C31 => b31
      | C32 => b32
      | C33 => b33
      end
  end.
*)


Require Import List.
Require Import NArith.
Require Import ZArith.

Local Open Scope Z.

Definition Znth {A} i l def := if i >=? 0 then nth (A := A) (Z.to_nat i) l def else def.
Hint Unfold Znth.

Fixpoint nat_upd_list {A} l n (a:A) :=
  match n, l with
  | _, nil => nil
  | O, h :: t => a :: t
  | S k, h :: t => h :: (nat_upd_list t k a)
  end.

Definition upd_list {A} l i a := if i >=? 0 then nat_upd_list (A := A) l (Z.to_nat i) a else l.
Hint Unfold upd_list.

Definition is_char_array (s:list Z) :=
  forall c, In c s -> -128 <= c < 128.

Definition is_cstring (s:list Z) :=
  is_char_array s /\ In 0 s.

Fixpoint strlen (s:list Z) :=
  match s with
  | nil => 0
  | 0 :: t => 0
  | c :: t => strlen t + 1
  end.

Lemma in_split_1st {A}:
  (forall x y:A, {x=y} + {x<>y}) ->
  forall (a:A) l,
  In a l ->
  exists l1 l2, l = l1 ++ a :: l2 /\
  ~In a l1.
Proof.
  intros eq_dec a l a_in_l.
  induction l.
  + simpl in a_in_l; contradiction.
  + destruct a_in_l, (eq_dec a a0).
    - exists nil, l; subst a0; simpl; auto.
    - symmetry in H; contradiction.
    - exists nil, l; subst a0; simpl; auto.
    - destruct (IHl H) as (l1 & l2 & induct_eq & not_in_prefix).
      exists (a0 :: l1), l2; subst l; firstorder.
Qed.

Lemma Zlength_nil:
  forall A, Zlength nil (A := A) = 0.
Proof.
  intros; rewrite Zlength_correct; auto.
Qed.

Lemma Zlength_cons {A}:
  forall (a:A) l, Zlength (a :: l) = Zlength l + 1.
Proof.
  intros; repeat rewrite Zlength_correct; simpl length; rewrite Nat2Z.inj_succ; omega.
Qed.

Lemma Zlength_ge_0 {A}:
  forall (l:list A), 0 <= Zlength l.
Proof.
  intros; rewrite Zlength_correct; apply Nat2Z.is_nonneg.
Qed.

Lemma Zlength_0_implies_nil {A}:
  forall (l:list A), Zlength l = 0 -> l = nil.
Proof.
  destruct l; auto; cut (0 <= Zlength l); [rewrite Zlength_cons; omega | apply Zlength_ge_0].
Qed.

Lemma Znth_0 {A}:
  forall (a:A) l d, Znth 0 (a :: l) d = a.
Proof.
  intros; unfold Znth; auto.
Qed.

Lemma Znth_plus_1 {A}:
  forall (a:A) i l d, i >= 0 -> Znth (i + 1) (a :: l) d = Znth i l d.
Proof.
  intros; unfold Znth; simpl.
  assert (i + 1 = Z.succ i) as succ_eq by omega.
  assert (i + 1 >=? 0 = true) as cond_eq_true by (apply Z.geb_le; omega).
  assert (i >=? 0 = true) as cond_eq_true' by (apply Z.geb_le; omega).
  rewrite cond_eq_true, cond_eq_true', succ_eq, Z2Nat.inj_succ by omega; auto.
Qed.

Lemma Znth_def_indep {A}:
  forall (l:list A) i d1 d2,
  0 <= i < Zlength l -> Znth i l d1 = Znth i l d2.
Proof.
  intros l i d1 d2 i_bounds; unfold Znth; rewrite Zlength_correct in *.
  assert (i >=? 0 = true) as i_ge_0_true by (apply Z.geb_le; omega).
  rewrite i_ge_0_true.
  apply nth_indep, Nat2Z.inj_lt.
  rewrite Z2Nat.id; omega.
Qed.

Lemma Znth_gen_prop {A}:
  forall (d:A) s P,
  (forall c, In c s -> P c) ->
  P d ->
  (forall i, P (Znth i s d)).
Proof.
  intros d s P P_in P_def i; unfold Znth.
  assert (forall i, P (nth (Z.to_nat i) s d)) as P_nth.
  {
    intros i'; destruct (nth_in_or_default (Z.to_nat i') s d) as [is_in | is_def].
    + apply P_in, is_in.
    + rewrite is_def; apply P_def.
  }
  case (i >=? 0); [ apply P_nth | apply P_def ].
Qed.

Lemma Znth_in {A}:
  forall (l:list A) i d, 0 <= i < Zlength l -> In (Znth i l d) l.
Proof.
  intros; unfold Znth; rewrite Zlength_correct in *.
  assert (i >=? 0 = true) as i_ge_0_true by (apply Z.geb_le; omega).
  rewrite i_ge_0_true.
  apply nth_In, Nat2Z.inj_lt; rewrite Z2Nat.id; omega.
Qed.

Lemma Znth_equiv {A}:
  forall (l l':list A) d,
  Zlength l = Zlength l' ->
  (forall i, 0 <= i < Zlength l ->
   Znth i l d = Znth i l' d) ->
  l = l'.
Proof.
  induction l.
  + intros; rewrite Zlength_nil in H; symmetry; apply Zlength_0_implies_nil; omega.
  + intros.
    assert (0 <= Zlength l) by (apply Zlength_ge_0).
    destruct l'.
    - rewrite Zlength_nil, Zlength_cons in H.
      omega.
    - assert (a = a0) by (apply H0 with (i := 0); rewrite Zlength_cons; omega).
      rewrite H2; apply f_equal, IHl with (d := d).
      * repeat rewrite Zlength_cons in H; omega.
      * intros; specialize H0 with (i := i + 1).
        do 2 rewrite Znth_plus_1 in H0 by omega.
        apply H0; rewrite Zlength_cons; omega.
Qed.

Lemma Znth_split_equiv {A}:
  forall (l1 l2 l l':list A) k d,
  (forall i, 0 <= i < k -> Znth i l1 d = Znth i l d) ->
  (forall i, 0 <= i < k -> Znth i l1 d = Znth i l' d) ->
  (forall i, k <= i -> Znth i l2 d = Znth i l d) ->
  (forall i, k <= i -> Znth i l2 d = Znth i l' d) ->
  Zlength l = Zlength l' ->
  l = l'.
Proof.
  intros l1 l2 l l' k d l1_l_eq l1_l'_eq l2_l_eq l2_l'_eq len_eq.
  apply Znth_equiv with (d0 := d); auto.
  intros i len_bounds.
  destruct (Z_lt_ge_dec i k).
  + apply eq_trans with (y := Znth i l1 d).
    - symmetry; apply l1_l_eq; omega.
    - apply l1_l'_eq; omega.
  + apply eq_trans with (y := Znth i l2 d).
    - symmetry; apply l2_l_eq; omega.
    - apply l2_l'_eq; omega.
Qed.

Lemma upd_list_nil {A}:
  forall i (a:A),
  upd_list nil i a = nil.
Proof.
  intros; unfold upd_list; destruct i; simpl; auto.
  case (Pos.to_nat p); auto.
Qed.

Lemma upd_list_plus_1 {A}:
  forall l i (a b:A),
  i >= 0 ->
  upd_list (a :: l) (i + 1) b = a :: (upd_list l i b).
Proof.
  intros; unfold upd_list; simpl.
  assert (i + 1 = Z.succ i) as succ_eq by omega.
  assert (i + 1 >=? 0 = true) as cond_eq_true by (apply Z.geb_le; omega).
  assert (i >=? 0 = true) as cond_eq_true' by (apply Z.geb_le; omega).
  rewrite cond_eq_true, cond_eq_true', succ_eq, Z2Nat.inj_succ by omega; auto.
Qed.

Lemma upd_list_Zlength {A}:
  forall l i (a:A),
  Zlength (upd_list l i a) = Zlength l.
Proof.
  induction l.
  + intros; rewrite upd_list_nil; auto.
  + intros; destruct i.
    - unfold upd_list; simpl; repeat rewrite Zlength_cons; auto.
    - remember (Z.pos p) as i.
      assert (i = i - 1 + 1) as i_eq by omega.
      assert (i > 0) by (rewrite Heqi; apply Zgt_pos_0).
      rewrite i_eq, upd_list_plus_1 by omega.
      repeat rewrite Zlength_cons; rewrite IHl by omega; auto.
    - unfold upd_list; simpl; auto.
Qed.

Lemma upd_list_doesnt_change {A}:
  forall l i j (a:A) d,
  i <> j ->
  Znth j (upd_list l i a) d = Znth j l d.
Proof.
  induction l.
  + intros; rewrite upd_list_nil; auto.
  + intros.
    assert (i = i - 1 + 1) as i_eq by omega.
    assert (j = j - 1 + 1) as j_eq by omega.
    destruct j.
    - destruct i.
      * intros; omega.
      * remember (Z.pos p) as i; assert (i > 0) by (rewrite Heqi; apply Zgt_pos_0).
        rewrite i_eq, upd_list_plus_1 by omega.
        repeat rewrite Znth_0; auto.
      * unfold upd_list; simpl; auto.
    - destruct i.
      * remember (Z.pos p) as j; assert (j > 0) by (rewrite Heqj; apply Zgt_pos_0).
        unfold upd_list; simpl.
        rewrite j_eq by omega.
        repeat rewrite Znth_plus_1 by omega; auto.
      * remember (Z.pos p) as j; assert (j > 0) by (rewrite Heqj; apply Zgt_pos_0).
        remember (Z.pos p0) as i; assert (i > 0) by (rewrite Heqi; apply Zgt_pos_0).
        rewrite i_eq, j_eq, upd_list_plus_1 by omega.
        repeat rewrite Znth_plus_1 by omega.
        apply IHl; omega.
      * unfold upd_list; simpl; auto.
    - unfold Znth; simpl; auto.
Qed.

Lemma upd_list_change {A}:
  forall l i (a:A) d,
  0 <= i < Zlength l ->
  Znth i (upd_list l i a) d = a.
Proof.
  induction l.
  + rewrite Zlength_nil; intros; omega.
  + destruct i.
    - unfold upd_list; simpl; intros; rewrite Znth_0; auto.
    - intros; remember (Z.pos p) as i.
      assert (i = i - 1 + 1) as i_eq by omega.
      assert (i > 0) by (rewrite Heqi; apply Zgt_pos_0).
      rewrite i_eq, upd_list_plus_1 by omega.
      rewrite Znth_plus_1 by omega.
      apply IHl.
      rewrite Zlength_cons in H; omega.
    - intros.
      assert (Z.neg p < 0) by apply Zlt_neg_0.
      omega.
Qed.

Lemma char_array_tail:
  forall c s, is_char_array (c :: s) -> is_char_array s.
Proof.
  intros c s c_s_is_carr c' c'_in_s; unfold is_char_array in *.
  apply c_s_is_carr, in_cons; auto.
Qed.

Lemma cstring_not_nil:
  ~is_cstring nil.
Proof.
  intros [_ nil_has_null]; apply in_nil with (a := 0); auto.
Qed.

Lemma cstring_tail:
  forall c s, is_cstring (c :: s) -> c = 0 \/ is_cstring s.
Proof.
  intros c s [c_s_is_carr c_s_has_null]; unfold is_cstring.
  destruct (Z.eq_dec c 0).
  + auto.
  + right; split.
    - apply char_array_tail with (c := c); auto.
    - inversion c_s_has_null; try contradiction; auto.
Qed.

Lemma strlen_abs_bounds:
  forall s, 0 <= strlen s <= Zlength s.
Proof.
  induction s as [|c].
  + rewrite Zlength_nil; simpl; omega.
  + rewrite Zlength_cons; destruct c; simpl; omega.
Qed.

Lemma strlen_prefix:
  forall c s, strlen (c :: s) <= strlen s + 1.
Proof.
  intros; assert (0 <= strlen s) by apply strlen_abs_bounds.
  destruct c; simpl; try intros; omega.
Qed.

Lemma strlen_nz_prefix:
  forall c s, c <> 0 -> strlen (c :: s) = strlen s + 1.
  intros; destruct c.
  + exfalso; apply H; auto.
  + simpl; auto.
  + simpl; auto.
Qed.

Lemma cstring_strlen_bounds:
  forall s, is_cstring s -> 0 <= strlen s < Zlength s.
Proof.
  induction s as [|c].
  + intros; exfalso; apply cstring_not_nil; auto.
  + intros c_s_is_cstr.
    assert (c = 0 \/ is_cstring s) as [c_eq_0 | s_is_cstr] by (apply cstring_tail; auto).
    - assert (0 <= Zlength s) by apply Zlength_ge_0.
      rewrite Zlength_cons, c_eq_0; simpl; omega.
    - assert (strlen (c :: s) <= strlen s + 1) by apply strlen_prefix.
      assert (0 <= strlen (c :: s)) by apply strlen_abs_bounds.
      rewrite Zlength_cons; specialize (IHs s_is_cstr); omega.
Qed.

Lemma cstring_strlen_content:
  forall s d,
  is_cstring s ->
  Znth (strlen s) s d = 0 /\
  forall j, 0 <= j < strlen s -> Znth j s d <> 0.
Proof.
  intros s d [_ s_has_null].
  assert (exists p t, (s = p ++ 0 :: t) /\ ~In 0 p) as
    (p & t & s_splitted & prefix_has_no_null) by
    (apply (in_split_1st Z.eq_dec); auto).
  clear s_has_null; subst s; induction p.
  {
    simpl; rewrite Znth_0; split; try intros; omega.
  }
  {
    assert (~In 0 p) as p_has_no_null by
      (intros abs; apply prefix_has_no_null, in_cons; auto).
    specialize (IHp p_has_no_null).
    destruct (Z.eq_dec a 0).
    + subst a; exfalso; apply prefix_has_no_null, in_eq.
    + split.
      - rewrite <-app_comm_cons, strlen_nz_prefix, Znth_plus_1; auto.
        * apply IHp.
        * assert (0 <= strlen (p ++ 0 :: t)) by (apply strlen_abs_bounds; auto); omega.
      - intros j j_bounds; destruct (Z.eq_dec j 0).
        * rewrite e, <-app_comm_cons, Znth_0; auto.
        * assert (j = j - 1 + 1) as j_eq by omega.
          rewrite <-app_comm_cons, strlen_nz_prefix in j_bounds by auto.
          rewrite j_eq, <-app_comm_cons, Znth_plus_1; try omega; apply IHp; omega; auto.
  }
Qed.

Lemma cstring_has_bounded_chars:
  forall c s, is_cstring s -> In c s -> -128 <= c < 128.
Proof.
  intros c s [s_is_carr _] c_in_s; unfold is_char_array in *.
  apply s_is_carr, c_in_s.
Qed.

Add Rec LoadPath "../verifiable-c/vst".
Add LoadPath "../verifiable-c/compcert" as compcert.

Require Import floyd.proofauto.
Require Import string_funcs.

Local Open Scope logic.

Lemma eqmod_small_eq_shifted:
  forall a b m k,
  k <= a < m + k ->
  k <= b < m + k ->
  Int.eqmod m a b ->
  a = b.
Proof.
  intros a b m k a_bounds b_bounds a_eqmod_b.
  cut (a - k = b - k); try omega.
  apply Int.eqmod_small_eq with (modul := m); try omega.
  apply Int.eqmod_add, Int.eqmod_refl; auto.
Qed.

Lemma eqmod_unsigned_repr:
  forall i n,
  0 < n < Int.zwordsize ->
  Int.eqmod (two_p n) (Int.unsigned (Int.repr i)) i.
Proof.
  intros i n n_bounds.
  apply Int.eqmod_divides with (n := Int.modulus).
  + fold Int.eqm.
    apply Int.eqm_unsigned_repr_l, Int.eqm_refl.
  + unfold Int.modulus.
    rewrite two_power_nat_two_p.
    fold Int.zwordsize.
    exists (two_p (Int.zwordsize - n)).
    rewrite <-two_p_is_exp by omega.
    assert (Int.zwordsize = Int.zwordsize - n + n) as ws_eq by omega.
    rewrite ws_eq at 1; auto.
Qed.

Lemma signed_ext_idempotence:
  forall i n,
  0 < n < Int.zwordsize ->
  -two_p (n - 1) <= i < two_p (n - 1) ->
  Int.sign_ext n (Int.repr i) = Int.repr i.
Proof.
  intros i n n_bounds i_bounds.
  assert (two_p n + - two_p (n - 1) = two_p (n - 1)) as two_p_eq.
  {
    assert (n = Z.succ (n - 1)) as n_eq by omega.
    rewrite n_eq at 1.
    rewrite two_p_S by omega.
    ring.
  }
  rewrite <-Int.repr_signed with (i := Int.sign_ext n (Int.repr i)).
  apply f_equal.
  apply eqmod_small_eq_shifted with (m := two_p n) (k := -two_p (n - 1)).
  + rewrite two_p_eq.
    apply Int.sign_ext_range; auto.
  + omega.
  + assert (Int.eqmod (two_p n)
                      (Int.signed (Int.sign_ext n (Int.repr i)))
                      (Int.unsigned (Int.repr i))) as eq_1 by
      (apply Int.eqmod_sign_ext; auto).
    assert (Int.eqmod (two_p n) (Int.unsigned (Int.repr i)) i) as eq_2 by
      (apply eqmod_unsigned_repr; auto).
    apply Int.eqmod_trans with (y := (Int.unsigned (Int.repr i))); auto.
Qed.

Lemma bool_char_eq_value:
  forall s i,
  is_char_array s ->
  0 <= i < Zlength s ->
  negb (Int.eq (Int.sign_ext 8 (Int.repr (Znth i s 0)))
               (Int.repr 0)) =
  negb (Z.eqb (Znth i s 0) 0).
Proof.
  intros s i s_is_carr i_bounds.
  assert (-128 <= Znth i s 0 < 128) as char_bound by (apply s_is_carr, Znth_in; auto).
  rewrite signed_ext_idempotence by (compute; auto).
  apply f_equal.
  destruct (eq_dec (Znth i s 0) 0).
  + rewrite e; simpl; apply Int.eq_true.
  + rewrite Int.eq_false.
    - symmetry; rewrite Z.eqb_neq; auto.
    - intros repr_eq.
      assert (Znth i s 0 = 0) as abs.
      {
        rewrite <-Int.signed_repr with (z := Znth i s 0) by
          (unfold Int.min_signed, Int.max_signed; simpl; omega).
        rewrite <-Int.signed_repr with (z := 0) at 2 by
          (unfold Int.min_signed, Int.max_signed; simpl; omega).
        rewrite repr_eq; auto.
      }
      contradiction.
Qed.

Lemma typecast_aux_lemma:
  forall s,
  is_int
    (force_val
       (sem_cast_i2i I8 Signed
          ((fun i : Z => Vint (Int.repr (Znth i s 1))) 0))).
Proof.
  unfold Znth; simpl; auto.
Qed.

Lemma cstring_in_lemma:
  forall i s,
  is_cstring s ->
  0 <= i <= strlen s ->
  negb (Int.eq (Int.sign_ext 8 (Int.repr (Znth i s 0)))
               (Int.repr 0)) = true ->
  i < strlen s.
Proof.
  intros i s s_is_cstr strlen_s_bounds char_eq.
  assert (0 <= strlen s < Zlength s) by (apply cstring_strlen_bounds; auto).
  rewrite bool_char_eq_value in char_eq by (destruct s_is_cstr; auto; omega).
  destruct (eq_dec i (strlen s)).
  + assert (Znth i s 0 = 0) as s_i_is_null by (rewrite e; apply cstring_strlen_content; auto).
    rewrite s_i_is_null in char_eq; simpl in char_eq; discriminate.
  + omega.
Qed.

Lemma cstring_end_lemma:
  forall i s,
  is_cstring s ->
  0 <= i <= strlen s ->
  negb (Int.eq (Int.sign_ext 8 (Int.repr (Znth i s 0)))
               (Int.repr 0)) = false ->
  strlen s = i.
Proof.
  intros i s s_is_cstr strlen_s_bounds char_eq.
  assert (0 <= strlen s < Zlength s) by (apply cstring_strlen_bounds; auto).
  rewrite bool_char_eq_value in char_eq by (destruct s_is_cstr; auto; omega).
  destruct (eq_dec i (strlen s)).
  + auto.
  + assert (forall j, 0 <= j < strlen s -> Znth j s 0 <> 0) as s_content_not_null by
      (apply cstring_strlen_content; auto).
    assert (Znth i s 0 <> 0) as char_ineq by (apply s_content_not_null; omega).
    assert (Znth i s 0 =? 0 = false) as char_eq_is_false by (apply Z.eqb_neq; auto).
    rewrite char_eq_is_false in char_eq; simpl in char_eq; discriminate.
Qed.

Lemma upd_lemma:
  forall i k arr c,
  0 <= i < Zlength arr ->
  -128 <= c < 128 ->
  (fun j => Vint (Int.repr (Znth j (upd_list arr i c) 1))) k =
  (upd (fun j => Vint (Int.repr (Znth j arr 1))) i
       (Vint (Int.sign_ext 8 (Int.repr c)))) k.
Proof.
  intros; rewrite signed_ext_idempotence by (compute; auto).
  unfold upd; destruct (eq_dec i k); simpl.
  + rewrite e, upd_list_change by omega; auto.
  + rewrite upd_list_doesnt_change by auto; auto.
Qed.

Definition my_strlen_spec :=
  DECLARE _my_strlen
    WITH s_arr: list Z, sh: share, s: val
    PRE [ _s OF tptr tschar ]
      PROP (is_cstring s_arr;
            Zlength s_arr <= Int.max_signed)
      LOCAL (`(eq s) (eval_id _s);
             `isptr (eval_id _s))
      SEP(`(array_at tschar sh (fun i => Vint (Int.repr (Znth i s_arr 1)))
                     0 (Zlength s_arr) s))
    POST [ tuint ]
      PROP ()
      LOCAL (`(eq (Vint (Int.repr (strlen s_arr)))) retval)
      SEP(`(array_at tschar sh (fun i => Vint (Int.repr (Znth i s_arr 1)))
                     0 (Zlength s_arr) s)).

Definition my_strcpy_spec :=
  DECLARE _my_strcpy
    WITH src_arr:list Z, dst_ini_arr:list Z, dst_fin_arr:list Z, sh: share,
         wsh:share, src:val, dst:val
    PRE [ _src OF tptr tschar ]
      PROP (is_cstring src_arr;
            Zlength src_arr <= Int.max_signed;
            Zlength dst_ini_arr <= Int.max_signed;
            Zlength dst_ini_arr > strlen src_arr;
            Zlength dst_fin_arr = Zlength dst_ini_arr;
            forall i,
            0 <= i < strlen src_arr -> Znth i dst_fin_arr 1 = Znth i src_arr 1;
            forall i,
            strlen src_arr <= i -> Znth i dst_fin_arr 1 = Znth i dst_ini_arr 1;
            writable_share wsh)
      LOCAL (`(eq src) (eval_id _src);
             `(eq dst) (eval_id _dst);
             `isptr (eval_id _src);
             `isptr (eval_id _dst))
      SEP(`(array_at tschar sh (fun i => Vint (Int.repr (Znth i src_arr 1)))
                     0 (Zlength src_arr) src);
          `(array_at tschar wsh (fun i => Vint (Int.repr (Znth i dst_ini_arr 1)))
                     0 (Zlength dst_ini_arr) dst))
    POST [ tptr tschar ]
      PROP ()
      LOCAL (`(eq dst) retval)
      SEP(`(array_at tschar sh (fun i => Vint (Int.repr (Znth i src_arr 1)))
                     0 (Zlength src_arr) src);
          `(array_at tschar wsh (fun i => Vint (Int.repr (Znth i dst_fin_arr 1)))
                     0 (Zlength dst_fin_arr) dst)).

Definition Vprog : varspecs := nil.
Definition Gprog : funspecs := my_strlen_spec :: my_strcpy_spec :: nil.

Lemma body_my_strlen:
  semax_body Vprog Gprog f_my_strlen my_strlen_spec.
Proof.
  start_function.
  name s_ _s.
  name i_ _i.
  name c_ _c.
  forward.
  forward.
  {
    entailer!.
    + assert (0 <= strlen s_arr < Zlength s_arr) by (apply cstring_strlen_bounds; auto); omega.
    + apply typecast_aux_lemma.
  }
  forward_while
  (EX i:Z, EX c:Z,
   PROP (forall j, 0 <= j < i -> Znth j s_arr 0 <> 0;
         0 <= i <= strlen s_arr;
         c = Znth i s_arr 0)
   LOCAL (`(eq (Vint (Int.repr i))) (eval_id _i);
          `(eq (Vint (Int.sign_ext 8 (Int.repr c)))) (eval_id _c);
          `(eq s) (eval_id _s);
          `isptr (eval_id _s))
   SEP(`(array_at tschar sh (fun i => Vint (Int.repr (Znth i s_arr 1)))
                  0 (Zlength s_arr) s)))
  (PROP ()
   LOCAL (`(eq (Vint (Int.repr (strlen s_arr)))) (eval_id _i);
          `(eq s) (eval_id _s))
   SEP(`(array_at tschar sh (fun i => Vint (Int.repr (Znth i s_arr 1)))
                  0 (Zlength s_arr) s))).
  {
    apply exp_right with 0.
    apply exp_right with (Znth 0 s_arr 0).
    entailer!.
    + intros; omega.
    + assert (0 <= strlen s_arr) by apply strlen_abs_bounds; omega.
    + assert (0 <= strlen s_arr < Zlength s_arr) by (apply cstring_strlen_bounds; auto).
      rewrite Znth_def_indep with (d2 := 1) by omega; auto.
  }
  {
    entailer!.
  }
  {
    entailer!.
    + cut (strlen s_arr = i).
      - apply f_equal.
      - apply cstring_end_lemma; auto.
  }
  {
    forward.
    forward.
    {
      assert (0 <= strlen s_arr < Zlength s_arr) by (apply cstring_strlen_bounds; auto).
      assert (i < strlen s_arr) by (apply cstring_in_lemma; auto).
      entailer!.
      + omega.
      + apply typecast_aux_lemma; auto.
    }
    {
      apply exp_right with (i + 1).
      apply exp_right with (Znth (i + 1) s_arr 0).
      entailer!.
      - assert (i < strlen s_arr) by (apply cstring_in_lemma; auto).
        intros; apply cstring_strlen_content; auto; omega.
      - assert (i < strlen s_arr) by (apply cstring_in_lemma; auto); omega.
      - assert (i < strlen s_arr) by (apply cstring_in_lemma; auto).
        assert (0 <= strlen s_arr < Zlength s_arr) by (apply cstring_strlen_bounds; auto).
        rewrite Int.signed_repr.
        * rewrite Znth_def_indep with (d2 := 1); auto; omega.
        * assert (Int.min_signed < 0) by apply Int.min_signed_neg; omega.
    }
  }
  forward.
Qed.

Lemma body_my_strcpy:
  semax_body Vprog Gprog f_my_strcpy my_strcpy_spec.
Proof.
  start_function.
  name src_ _src.
  name dst_ _dst.
  name c_ _c.
  name i_ _i.
  forward.
  forward.
  {
    entailer!.
    + assert (0 <= strlen src_arr < Zlength src_arr) by (apply cstring_strlen_bounds; auto).
      omega.
    + apply typecast_aux_lemma.
  }
  forward_while
  (EX i:Z, EX c:Z, EX dst_arr:list Z,
   PROP(Zlength dst_arr = Zlength dst_ini_arr;
        forall j,
        0 <= j < i ->
        Znth j dst_arr 1 = Znth j src_arr 1;
        forall j,
        i <= j ->
        Znth j dst_arr 1 = Znth j dst_ini_arr 1;
        0 <= i <= strlen src_arr;
        c = Znth i src_arr 0)
   LOCAL (`(eq (Vint (Int.repr i))) (eval_id _i);
          `(eq (Vint (Int.sign_ext 8 (Int.repr c)))) (eval_id _c);
          `(eq src) (eval_id _src);
          `(eq dst) (eval_id _dst);
          `isptr (eval_id _src))
   SEP(`(array_at tschar sh (fun i => Vint (Int.repr (Znth i src_arr 1)))
                  0 (Zlength src_arr) src);
       `(array_at tschar wsh (fun i => Vint (Int.repr (Znth i dst_arr 1)))
                  0 (Zlength dst_arr) dst)))
  (PROP ()
   LOCAL (`(eq dst) (eval_id _dst))
   SEP(`(array_at tschar sh (fun i => Vint (Int.repr (Znth i src_arr 1)))
                  0 (Zlength src_arr) src);
       `(array_at tschar wsh (fun i => Vint (Int.repr (Znth i dst_fin_arr 1)))
                  0 (Zlength dst_fin_arr) dst))).
  {
    apply exp_right with 0.
    apply exp_right with (Znth 0 src_arr 0).
    apply exp_right with dst_ini_arr.
    entailer!.
    + intros; omega.
    + assert (0 <= strlen src_arr < Zlength src_arr) by (apply cstring_strlen_bounds; auto).
      omega.
    + assert (0 <= strlen src_arr < Zlength src_arr) by (apply cstring_strlen_bounds; auto).
      rewrite Znth_def_indep with (d2 := 1); auto; omega.
  }
  {
    entailer!.
  }
  {
    entailer!.
    assert (strlen src_arr = i) by (apply cstring_end_lemma; auto).
    rewrite Znth_split_equiv
      with (l := dst_arr) (l' := dst_fin_arr) (l1 := src_arr) (l2 := dst_ini_arr)
           (k := strlen src_arr) (d := 1).
    + entailer!.
    + intros; rewrite H8; omega.
    + intros; rewrite H4; omega.
    + intros; rewrite H9; omega.
    + intros; rewrite H5; omega.
    + omega.
  }
  {
    forward.
    {
      instantiate (1 := Vint (Int.sign_ext 8 (Int.repr (Znth i src_arr 0)))).
      instantiate (2 := i).
      assert (offset_val (Int.repr i) (eval_id _dst rho) =
             force_val (sem_add_pi tschar (eval_id _dst rho) (eval_id _i rho))).
      {
        rewrite <-H13, sem_add_pi_ptr, mul_repr; case i; simpl; auto.
      }
      assert (Vint (Int.sign_ext 8 (Int.repr (Znth i src_arr 0))) =
             force_val (sem_cast_i2i I8 Signed (eval_id _c rho))).
      {
        rewrite <-H14; simpl; rewrite Int.sign_ext_idem; auto; omega.
      }
      entailer.
    }
    forward.
    forward.
    {
      entailer!.
      + assert (i < strlen src_arr) by (apply cstring_in_lemma; auto; omega).
        assert (0 <= strlen src_arr < Zlength src_arr) by (apply cstring_strlen_bounds; auto).
        omega.
      + apply typecast_aux_lemma; auto.
    }
    apply exp_right with (i + 1).
    apply exp_right with (Znth (i + 1) src_arr 0).
    apply exp_right with (upd_list dst_arr i c).
    entailer!.
    + rewrite upd_list_Zlength; auto.
    + intros; destruct (eq_dec x i).
      - rewrite e, upd_list_change by omega.
        apply Znth_def_indep.
        assert (0 <= strlen src_arr < Zlength src_arr) by (apply cstring_strlen_bounds; auto).
        omega.
      - rewrite upd_list_doesnt_change by omega.
        apply H8; omega.
    + intros; rewrite upd_list_doesnt_change by omega.
      apply H9; omega.
    + assert (i < strlen src_arr) by (apply cstring_in_lemma; auto).
      omega.
    + rewrite Znth_def_indep with (d2 := 1); auto.
      assert (0 <= strlen src_arr < Zlength src_arr) by (apply cstring_strlen_bounds; auto).
      assert (i < strlen src_arr) by (apply cstring_in_lemma; auto).
      omega.
    + assert (0 <= strlen src_arr < Zlength src_arr) by (apply cstring_strlen_bounds; auto).
      assert (-128 <= Znth i src_arr 0 < 128) by (apply H, Znth_in; omega).
      rewrite upd_list_Zlength by omega.
      apply array_at_ext'.
      intros; symmetry; apply upd_lemma; omega.
  }
  forward.
Qed.