(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Bihong Zhang <sa614257@mail.ustc.edu.cn>                         *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

(*

*)

(* ************* ************************************* *****)
(* ftl interface *)

Require Import ListEx.
Require Import Monad.
Require Import Data.
Require Import Params.
Require Import Nand.
Require Import NPeano.
Require Import bnat.

Definition bvalid_logical_page_no (lpn: page_no) := blt_nat lpn (MAX_LOGICAL_BLOCKS * PAGES_PER_BLOCK).

Definition valid_page_no (ppn: page_no):Prop := bvalid_page_no ppn = true.

(*
Cache mapping table

The cmt_record is (lpn,ppn,flag,time).The init cmt is all the cmt_empty.
*)

Inductive flag :Set :=
 | dirty:flag
 | clean:flag.

Inductive cmt_record: Set :=
| cmt_empty
| cmt_trans(lpn:page_no)(pbn:block_no)(offset:nat)(is_dirty:flag).

Definition cache_mapping_table := list cmt_record.

Fixpoint  find_empty_cmt(cmt:cache_mapping_table) (i:nat): option nat :=
  match cmt with
  | nil => None
  | cons a cmt' => match a with
                     | cmt_empty => Some i
                     | _ => find_empty_cmt cmt' (S i)
                   end
end.

Definition cmt_get(cmt : cache_mapping_table) (loc: nat) : option cmt_record :=
  list_get cmt loc.

Definition cmt_set(cmt: cache_mapping_table) (loc: nat) (newrecord:cmt_record): option cache_mapping_table :=
  list_set cmt loc newrecord.

Definition cmt_get_trans(record:cmt_record) : option (prod (prod block_no page_no) flag)  :=
  match record with
      | cmt_empty => None
      | cmt_trans lpn pbn off f => ret((pbn,off),f)
end.

Fixpoint cmt_in (cmt:cache_mapping_table) (lpn:page_no) :bool :=
  match cmt with
      | nil => false
      | cons a cmt' => match a with
                           | (cmt_trans lpn' _ _ _) => if beq_nat lpn lpn' then true else cmt_in cmt' lpn
                           | _ => cmt_in cmt' lpn
                       end
  end.

Fixpoint find_cmtrecord(cmt:cache_mapping_table)(lpn:page_no)(i:nat) : option nat :=
  match cmt with
    | nil => None
    | cons a cmt' => match a with
                         |(cmt_trans lpn' _ _ _) =>if beq_nat lpn' lpn then Some i else find_cmtrecord cmt' lpn (S i)
                         | _ => find_cmtrecord cmt' lpn (S i)
                     end
end.

Fixpoint remove_cmt(cmt:cache_mapping_table) (lpn:page_no):  cache_mapping_table :=
  match cmt with
    | nil => nil
    | cons a cmt' => match a with
                         |(cmt_trans lpn' _  _ _) =>if beq_nat lpn' lpn then cmt' else cons a (remove_cmt cmt' lpn)
                         | _ => cons a (remove_cmt cmt' lpn)
                     end
end.

Fixpoint insert_cmt (cmt:cache_mapping_table) (record:cmt_record) (num:nat) :cache_mapping_table :=
  match num with
      | O => cons record cmt
      | S i => match cmt with
                 | nil => nil
                 | cons a cmt' => (cons a (insert_cmt cmt' record i ) )
                end
   end.

Definition remove_head(cmt:cache_mapping_table) : option cache_mapping_table :=
  match cmt with
      | nil => None
      | cons a cmt' => Some cmt'
end.

Fixpoint append_tail(cmt:cache_mapping_table)(newrecord:cmt_record) : cache_mapping_table :=
  match cmt with
      | nil => cons newrecord nil
      | cons a nil => cons a (cons newrecord nil)
      | cons a cmt' => cons a (append_tail cmt' newrecord)
end.

(*Init the cache mapping table *)
Fixpoint init_cmt(cmt:cache_mapping_table)(i:nat): option cache_mapping_table :=
  match i with
|  O => None
|  S O => Some cmt
|  S i' => init_cmt (list_append cmt cmt_empty) i'
end.

Definition blank_cmt : cache_mapping_table :=
  list_repeat_list CMT_LENGTH cmt_empty.

(*
Global translation table

The length of the gtd is fixed.The record is(index,ppn).
*)

(* Inductive gtd_record: Set := *)
(* | gtd_empty *)
(* | gtd_trans (pbn:block_no) (offset:nat ). *)

Inductive gtd_record: Set :=
| gtd_empty
| gtd_trans:block_no ->nat->gtd_record.

(* Inductive gtd_record': Set := *)
(* | gtd_empty *)
(* | gtd_trans:forall (pbn:block_no) (offset:nat), gtd_record'. *)

Definition global_mapping_directory := list gtd_record.

(* Definition gtd_len(gtd:global_mapping_directory) : nat :=  *)
(*   length gtd. *)

Definition gtd_get(gtd:global_mapping_directory)(loc: nat) : option gtd_record :=
  list_get gtd loc.

Definition gtd_set(gtd:global_mapping_directory) (loc: nat) (newrecord:gtd_record): option global_mapping_directory :=
  list_set gtd loc newrecord.

(* SearchAbout andb. *)
Fixpoint gtd_look_by_record(gtd:global_mapping_directory)(lbn:block_no) (off:nat) (num:nat) : option nat :=
  match gtd with
      | nil  => None
      | cons record' gtd' => match record' with
                                 | gtd_empty => gtd_look_by_record gtd' lbn off (S num)
                                 | gtd_trans lbn' off' => if andb (beq_nat lbn lbn') (beq_nat off off')  then Some num else gtd_look_by_record gtd' lbn off (S num)

                             end
end.

Fixpoint gtd_look_by_lpn_aux (gtd:global_mapping_directory) (lpn:page_no) (num:nat):option nat :=
  test bvalid_logical_page_no lpn;
  match gtd with
      | nil => None
      | cons record' l => if blt_nat lpn (((S num) * RECORD_PER_TRANS)) then Some num else gtd_look_by_lpn_aux l lpn (S num)
end.

Fixpoint gtd_look_by_lpn (gtd:global_mapping_directory) (lpn:page_no):option nat :=
  gtd_look_by_lpn_aux gtd lpn 0.

(* Definition gtd_look_by_lpn (gtd:global_mapping_directory) (lpn:page_no) :option nat :=  *)
(*   test bvalid_logical_page_no lpn; *)
(*   Some (lpn / RECORD_PER_TRANS). *)

Definition  gtd_get_trans_by_lpn(gtd:global_mapping_directory)(lpn:page_no):option (prod nat nat) :=
  do gtd_loc <-- gtd_look_by_lpn gtd lpn;
  do record <-- gtd_get gtd gtd_loc;
  match record with
      | gtd_empty => None
      | gtd_trans pbn off => ret (pbn,off)
end.

Fixpoint init_gtd(gtd:global_mapping_directory)(i:nat): option global_mapping_directory :=
  match i with
|  O => None
|  S O => Some gtd
|  S i' => init_gtd (list_append gtd gtd_empty) i'
end.

Definition blank_gtd : global_mapping_directory :=
  list_repeat_list GTD_LENGTH gtd_empty.

(* Compute ( *)
(*  do gtd <-- Some blank_gtd; *)
(*  do i <-- gtd_look_by_lpn gtd 7 0; *)
(*  ret i *)
(* ). *)
(*
Trans_page data

The data of trans_page is (lpn,ppn)
*)

(* Inductive trans_record: Set := *)
(*   | trans_empty *)
(*   | trans_data(lpn:page_no)(ppn:page_no). *)

(* Definition trans_page := list trans_record. *)

(* Definition trans_len(trans:trans_page) : nat :=  *)
(*   length trans. *)

(* Definition trans_get(trans:trans_page)(loc: nat) : option trans_record := *)
(*   list_get trans loc. *)

(* Definition trans_set(trans:trans_page) (loc: nat) (newrecord:trans_record): option trans_page := *)
(*   list_set trans loc newrecord. *)

(*
FTL block state
*)

Inductive ftl_block_state : Set :=
  | bs_invalid
  | bs_erased
  | bs_data
  | bs_trans.

Inductive ftl_page_state : Set :=
  | ps_invalid
  | ps_erased
  | ps_data  (lpn:page_no)
  | ps_trans (gtd_loc:nat).

Definition page_state_table := list ftl_page_state.

Definition pst_get(pst:page_state_table)(loc: nat) : option ftl_page_state :=
  list_get pst loc.

Definition pst_set(pst:page_state_table) (loc: nat) (newstate:ftl_page_state): option page_state_table :=
  list_set pst loc newstate.

Definition pst_set_all (state:ftl_page_state):page_state_table  :=
  list_repeat_list  PAGES_PER_BLOCK state.

(*
Block_info_table
*)

Record block_info : Set :=
  mk_bi {
      bi_state: ftl_block_state;
      bi_used_pages: nat;
      bi_erase_count: nat;
      bi_page_state: page_state_table
    }.

Definition block_info_table :=  list block_info.

Definition bi_set_state (bi : block_info) (bi_state : ftl_block_state) : block_info :=
  mk_bi bi_state (bi_used_pages bi) (bi_erase_count bi) (bi_page_state bi).

(* set both the block and page state *)
Definition pi_set_state (bi : block_info) (bi_state : ftl_block_state) (bi_page_state:page_state_table) : block_info :=
  mk_bi bi_state (bi_used_pages bi) (bi_erase_count bi) bi_page_state.

Definition bit_get (bit: block_info_table) (b: block_no)
     : option block_info :=
  list_get bit b.

Definition bit_update (bit: block_info_table) (b: block_no) (bi: block_info)
      : option block_info_table :=
  list_set bit b bi.

(* In FTL, a block is initialized to be 'bs_invalid' *)
Definition blank_bi : block_info :=
  mk_bi bs_erased 0 0 (pst_set_all ps_erased).

(*
Free block queue

Free blocks are those not used, and each of them can be invalid or
erased (filled with \og{0xFF}). All the free blocks are put into a
queue, where a new allocated block is get from the head.
*)

Definition block_queue := list block_no.

Definition fbq_enq (fbq : block_queue) (b : block_no) : option (block_queue) :=
  Some (list_append fbq b).

Definition fbq_deq (fbq : block_queue) : option (prod block_no (block_queue)) :=
  match fbq with
    | nil => None
    | cons b fbq' => Some (b, fbq')
  end.

Definition fbq_in (fbq: list block_no) (pbn: block_no) : bool := list_inb beq_nat fbq pbn.

Definition fbq_get (fbq: list block_no) (i: nat) : option block_no := list_get fbq i.

Definition check_block_is_full (bi: block_info) : bool :=
  match blt_nat (bi_used_pages bi) PAGES_PER_BLOCK with
    | true => false
    | false => true
  end.

(*

Currnt data/translation block

*)

(* Definition current_data_block := block_no. *)

(* Definition current_trans_block := block_no. *)

(*
FTL structure
*)

Record FTL : Set :=
  mk_FTL {
      ftl_bi_table: block_info_table;
      ftl_free_blocks: block_queue;
      ftl_cmt_table:cache_mapping_table;
      ftl_gtd_table:global_mapping_directory;
      current_data_block:block_no;
      current_trans_block:block_no
    }.

Definition ftl_update_bit (f: FTL) (bit: block_info_table) : option FTL :=
  ret mk_FTL bit (ftl_free_blocks f) (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) (current_trans_block f).

Definition ftl_update_fbq (f: FTL) (fbq: block_queue) : option FTL :=
  ret mk_FTL (ftl_bi_table f) fbq  (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) (current_trans_block f).

Definition ftl_update_cmt (f: FTL) (cmt: cache_mapping_table) : option FTL :=
  ret mk_FTL (ftl_bi_table f)  (ftl_free_blocks f) cmt (ftl_gtd_table f) (current_data_block f) (current_trans_block f).

Definition ftl_update_cur_trans (f: FTL) (pbn:block_no) : option FTL :=
  ret mk_FTL (ftl_bi_table f) (ftl_free_blocks f) (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) pbn.

Definition ftl_update_cur_data (f: FTL) (pbn:block_no) : option FTL :=
  ret mk_FTL (ftl_bi_table f) (ftl_free_blocks f) (ftl_cmt_table f) (ftl_gtd_table f)  pbn (current_trans_block f).

Inductive freebq_state : Set :=
  | fbqs_abundant
  (* | fbqs_needgc *)
  | fbqs_scarce.

(* IMPORTANT !!! *)
Definition check_freebq_count (freebq: block_queue): freebq_state :=
  match (ble_nat MIN_FREE_BLOCKS (length freebq)) with
    | false => fbqs_scarce
    | true => fbqs_abundant
  end.

(* ****************************************************

   * ReadBlock/WriteBlock Operations
*)

Definition read_block (c: chip) (pbn: block_no) (off: page_off) : option data :=
  (* read the page from "off" in pbn_data *)
  do [d, o] <-- (nand_read_page c pbn off);

  (* return the data in the page *)
  ret d.

Definition read_block_oob (c: chip) (pbn: block_no) (off: page_off) : option (prod data page_oob_nat) :=
  (* read the page from "off" in pbn_data *)
  do [d, o] <-- (nand_read_page c pbn off);
  ret (d,o).

Definition write_data_block (c: chip) (pbn_bi: block_info) (pbn: block_no)
           (loc: page_off) (d: data) (oob:page_oob_nat)(page_state:ftl_page_state): option (prod chip block_info) :=
  (* write the data to "pbn#loc", return c' *)
  let pst := bi_page_state pbn_bi in
  do c' <-- (nand_write_page c pbn loc d oob);
  do pst' <-- pst_set pst loc page_state;
  (* return bi := <bi_state, used+1, ec> *)
  let bi' := mk_bi (bi_state pbn_bi) ((bi_used_pages pbn_bi)+1) (bi_erase_count pbn_bi) pst' in

  ret  (c', bi').

(* Definition read_trans_block (c: chip) (bi: block_info) (pbn_log: block_no) (off: page_off) : option data := *)
(*   (* find the lastest log page for "poff" in 'bk' , return the log-location *) *)
(*   do loc <-- (find_page_in_log_block bi off); *)

(*   (* read the page from "loc" in pbn_log *) *)
(*   do [d, o] <-- (nand_read_page c pbn_log loc);  *)

(*   (* return the data in the page *) *)
(*   ret d. *)

(* Definition write_trans_block *)

(*
FTL read algorithm

*)

Definition zero_page := (zero_data PAGE_DATA_SIZE).

(*
* Check the current_data_block and current_trans_block
*)

Definition check_current_block(bit:block_info_table) (pbn: block_no):option bool :=
  do bi <-- bit_get bit pbn;
  match check_block_is_full bi with
     | false => Some false
     | true => Some true
  end.

Fixpoint find_trans_in_metatrans(l:meta_trans_record_list) (lpn:page_off) : option (prod nat nat) :=
  match l with
      | nil => None
      | cons record l' =>match record with
                             | trans_empty => find_trans_in_metatrans l' lpn
                             | trans_data lpn' pbn' off' => if beq_nat lpn lpn' then Some (pbn',off') else find_trans_in_metatrans l' lpn
                          end
end.

(* Definition div (n1:nat)(n2:nat):nat := 1. *)

(* Definition mod (n1:nat)(n2:nat):nat := 1. *)

Definition check_block_full(bi:block_info): bool :=
  do num <<-- (bi_used_pages bi);
  match blt_nat num PAGES_PER_BLOCK with
      | true =>  false
      | false => true
 end.

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

(*
Init the ftl and nand
*)
Definition bit_init : block_info_table :=
  list_repeat_list BLOCKS blank_bi.

Definition cmt_init :cache_mapping_table := blank_cmt.

Definition gtd_init_empty : global_mapping_directory := blank_gtd.

Definition fbq_init : block_queue :=
  list_make_nat_list BLOCKS.

Definition bit_init_current:option block_info_table :=
  do bit <-- Some bit_init;
  do bit' <-- bit_update bit 0 (mk_bi bs_data 0 0 (pst_set_all ps_erased) );
  do bit'' <-- bit_update bit' 1 (mk_bi bs_trans 0 0  (pst_set_all ps_erased) );
  ret bit''.

Definition fbq_init_current:option block_queue :=
  do [_,fbq'] <-- fbq_deq fbq_init;
  do [_,fbq''] <-- fbq_deq fbq';
  ret fbq''.

Definition ftl_init : option FTL :=
   do bit <-- bit_init_current;
   do fbq <-- fbq_init_current;
   ret (mk_FTL bit fbq cmt_init gtd_init_empty 0 1).

(* Fixpoint gtd_init_trans(c:chip) (f:FTL) (gtd:global_mapping_table) (num:nat):option FTL := *)
(*   match num with *)
(*       | O => ret f *)
(*       | S i => do cur_trans <-- Some (current_trans_block f); *)
(*                do bit <-- ftl_bi_table f; *)
(*                do cur_trans_bi <-- bit_get bit cur_trans; *)
(*                match  check_block_full cur_trans_bi with *)
(*                    | false => do off <-- Some (bi_used_pages cur_trans_bi); *)
(*                               do gtd' <-- gtd_set gtd (minus 32 num) (gtd_trans cur_trans off); *)
(*                               do bit' <-- bit_update bit'; *)
(*                               do f' <-- (mk_FTL ( *)

(*
The meta_trans_data Definition && Operations

*)
Definition data_metatrans_get(dmt : meta_trans_record_list) (loc: nat) : option trans_record :=
  list_get dmt loc.

Definition data_metatrans_set(dmt: meta_trans_record_list) (loc: nat) (newrecord:trans_record): option meta_trans_record_list :=
  list_set dmt loc newrecord.

Definition blank_dmt :meta_trans_record_list  :=
  list_repeat_list RECORD_PER_TRANS trans_empty.

Fixpoint find_meta_trans_record(l:meta_trans_record_list)(lpn:page_no)(i:nat) :option nat :=
  match l with
      | nil =>None
      | cons record l' =>  match record with
                           | trans_empty => find_meta_trans_record l' lpn (S i)
                           | trans_data lpn' _ _ => if beq_nat lpn lpn' then Some i else find_meta_trans_record l' lpn (S i)
                          end
end.

Fixpoint find_meta_trans_empty(l:meta_trans_record_list)(lpn:page_no)(i:nat) :option nat :=
  match l with
      | nil =>None
      | cons record l' =>  match record with
                           | trans_empty => Some i
                           | trans_data lpn' _ _ => find_meta_trans_empty l' lpn (S i)
                          end
end.

Fixpoint get_meta_trans_record (l:meta_trans_record_list)(lpn:page_no)(i:nat) : option (prod block_no page_no) :=
  (* do i <-- find_meta_trans_record l lpn 0; *)
  do record <-- data_metatrans_get l i;
  match record with
      | trans_data lpn pbn off => ret (pbn,off)
      | _ => None
  end.

Fixpoint copy_data_trans(l:meta_trans_record_list) (lpn:page_no) (newrecord:trans_record) : option meta_trans_record_list :=
  match find_meta_trans_record l lpn 0 with
      | Some loc => do l' <-- data_metatrans_set l loc newrecord;
                    ret l'
      | None => do empty_loc <-- find_meta_trans_empty l lpn 0;
                do l' <-- data_metatrans_set l empty_loc newrecord;
                ret l'
   end.

(*
Invalid the block page
*)
Definition invalid_old_page(bit:block_info_table)(pbn:block_no)(off:nat) :option block_info_table :=
  do bi <-- bit_get bit pbn;
  do pst <-- Some (bi_page_state bi);
  do pst' <--  pst_set pst off ps_invalid;
  do bi' <-- Some (pi_set_state bi (bi_state bi) pst');
  do bit' <-- bit_update bit pbn bi';
  ret bit'.

(* ****************************************************
* Alloc_Block

Allocation block routine, no GC yet. But I believe that it will be
not difficult to add a simple GC.

*)

Inductive alloc_block_type:Set :=
  | alloc_trans_block:alloc_block_type
  | alloc_data_block:alloc_block_type.

Inductive gc_block_type:Set :=
  | gc_trans_block:gc_block_type
  | gc_data_block:gc_block_type.

Definition set_alloc_block_status (flag:alloc_block_type):ftl_block_state :=
  match flag with
      | alloc_trans_block => bs_trans
      | alloc_data_block => bs_data
  end.

Definition bit_set_state (bit: block_info_table) (pbn: block_no) (st: ftl_block_state) (pst:page_state_table)
  : option block_info_table :=
  do bi <-- bit_get bit pbn;
  do bi' <-- Some (mk_bi st (bi_used_pages bi) (bi_erase_count bi) pst);
  do bit' <-- bit_update bit pbn bi';
  ret bit'.

Definition bit_get_bstate (f: FTL) (pbn: block_no) : option ftl_block_state :=
  do bi <-- bit_get (ftl_bi_table f) pbn;
  ret (bi_state bi).

(* ****************************************************
* Auxiliary Routines for update Meta-Data
*)

Definition free_block (bit: block_info_table) (fbq: block_queue) (pbn: block_no)
  : option (prod block_info_table block_queue) :=
  do bi <-- bit_get bit pbn;
  do pst <-- Some (pst_set_all ps_invalid);
  do bi' <-- Some (mk_bi bs_invalid (bi_used_pages bi) (bi_erase_count bi) pst);
  do bit' <-- bit_update bit pbn bi';
  do fbq' <-- fbq_enq fbq pbn;
  ret (bit', fbq').

(* **********************************************************
*
*)
(*
The Garbge Collection
*)

(*
The gc trans block
*)

(* Definition gc(c:chip) (f:FTL)(flag:alloc_block_type):option (prod chip FTL) :=  *)
Definition alloc_gc_block (c: chip) (f: FTL) : option (prod block_no (prod chip FTL)) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  do [b, fbq'] <-- fbq_deq fbq;
  do bi_free <-- bit_get bit b;
  match bi_state bi_free with
     | bs_erased =>
       (* TODO:  we don't need to update bit. No,we need,we set the used_pages and pages_state *)
       do bit' <-- bit_update bit b (mk_bi bs_erased 0 (bi_erase_count bi_free) (pst_set_all ps_erased));
       ret (b, (c, (mk_FTL bit'  fbq' (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) (current_trans_block f) )))

     | bs_invalid =>
       do c' <-- nand_erase_block c b;
       do bit' <-- bit_update bit b (mk_bi bs_erased 0 (1 + bi_erase_count bi_free) (pst_set_all ps_erased));
       ret (b, (c',(mk_FTL bit' fbq' (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) (current_trans_block f) )))

     | _ => None
  end.

Definition gc_copy_trans_page (c:chip) (f:FTL) (pbn:block_no) (off:nat)(gtd_loc:nat) : option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let gtd := ftl_gtd_table f in
  let fbq := ftl_free_blocks f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  do cur_trans_info <-- bit_get bit cur_trans;
  do cur_trans_off <-- Some (bi_used_pages cur_trans_info);
  do [trans_d,oob] <-- read_block_oob c pbn off;
  (* Also it can look from the page_status *)
  (* do gtd_loc <-- gtd_look_by_record gtd pbn off 0; *)
  do [c',cur_bi'] <-- write_data_block c cur_trans_info cur_trans cur_trans_off trans_d oob (ps_trans gtd_loc) ;
  do bit' <-- bit_update bit cur_trans cur_bi';
  do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_trans_off);
  do new_f <-- Some (mk_FTL bit'  fbq cmt gtd' cur_data cur_trans);
  ret(c',new_f).

Definition invalid_old_block(bit:block_info_table)(pbn:block_no) :option block_info_table :=
  do bi <-- bit_get bit pbn;
  do pst <-- Some (pst_set_all ps_invalid);
  do bi' <-- Some (pi_set_state bi (bs_invalid) pst);
  do bit' <-- bit_update bit pbn bi';
  ret bit'.

(*
Assume:we have already look for the invaild trans_block:pbn
*)

Fixpoint  gc_trans_page (c:chip) (f:FTL) (pbn:block_no) (i:nat) :option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_data := current_data_block f in
  let cur_trans := current_trans_block f in
  do bi <-- bit_get bit pbn;
  do pst <-- Some ( bi_page_state bi );
  match i with
      | O => (* free_block also will do this *)
             do bit' <-- invalid_old_block bit pbn;
             ret(c,(mk_FTL bit' fbq cmt gtd cur_data cur_trans) )

      | S i' => do ps <-- pst_get pst i';
                match ps with
                    | ps_trans gtd_loc =>  do [c',f'] <-- gc_copy_trans_page c f pbn i' gtd_loc;
                                           gc_trans_page c' f' pbn i'

                    | _ =>  gc_trans_page c f pbn i'

                 end
   end.

(*
Return a (c,f),means have a empty page in the translation page
*)
Definition gc_trans(c:chip) (f:FTL)(pbn:block_no):option (prod chip FTL) :=
  let fbq := ftl_free_blocks f in
  (*alloc a trans page*)
  do [cur_trans,cf] <-- alloc_gc_block c f;
  do [c',f'] <-- Some cf;
  do bi <-- bit_get (ftl_bi_table f') cur_trans;
  do bi' <-- Some (bi_set_state bi bs_trans);
  do bit' <-- bit_update (ftl_bi_table f') cur_trans bi';
  (* still have a probelm --> Done *)
  do f'' <-- ftl_update_cur_trans f' cur_trans;
  do f''' <-- ftl_update_bit f'' bit';
  (*GC*)
  do [c'',f4] <-- gc_trans_page c' f''' pbn PAGES_PER_BLOCK;
  (* enter_free_blocks *)
  do bit'' <-- Some (ftl_bi_table f4);
  do fbq' <-- Some (ftl_free_blocks f4);
  do [bit''',fbq''] <-- free_block bit'' fbq' pbn;
  do f5 <-- ftl_update_bit f4 bit''';
  do f6 <-- ftl_update_fbq f5 fbq'';
  ret (c'',f6).

(* ------------------------------------------------------------------------------- *)
(*
TO DO Invalid the old_data,but copy_trans_page do this
*)

Definition gc_copy_data_page (c:chip) (f:FTL) (pbn:block_no) (off:nat) (lpn:page_no): option (prod (prod nat  nat) (prod chip FTL) ) :=
  let bit := ftl_bi_table f in
  let gtd := ftl_gtd_table f in
  let fbq := ftl_free_blocks f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  do cur_data_info <-- bit_get bit cur_data;
  do cur_data_off <-- Some (bi_used_pages cur_data_info);
  do [data_d,oob] <-- read_block_oob c pbn off;
  do [c',cur_bi'] <-- write_data_block c cur_data_info cur_data cur_data_off data_d oob (ps_data lpn) ;
  do bit' <-- bit_update bit cur_data cur_bi';
  do new_f <-- Some (mk_FTL bit' fbq cmt gtd cur_data cur_trans);
  ret((cur_data,cur_data_off),(c',new_f)).

Fixpoint check_invalid_page (f:FTL)(num:nat)(i:nat):option bool :=
  do bit <-- Some (ftl_bi_table f);
  do bi <-- bit_get bit num;
  do pst <-- Some (bi_page_state bi);
  match i with
      | O => Some false
      | S i' => do ps_state <-- pst_get pst i';
                match ps_state with
                    | ps_invalid => Some true
                    | ps_erased => Some true
                    | _ => check_invalid_page f num i'
                 end
  end.

Definition check_valid_gc_block (f:FTL) (t:gc_block_type) (num:nat): option bool :=
  do bit <-- Some (ftl_bi_table f);
  do bi <-- bit_get bit num;
  do bs_status <-- Some (bi_state bi);
  match t with
      | gc_trans_block => match bs_status with
                             | bs_trans => match check_invalid_page f num PAGES_PER_BLOCK with
                                               | Some true => Some true
                                               | _ => Some false
                                           end
                             | _ => Some false
                         end
      | gc_data_block => match bs_status with
                             | bs_data => match check_invalid_page f num PAGES_PER_BLOCK with
                                               | Some true => Some true
                                               | _ => Some false
                                           end
                             | _ => Some false
                         end
  end.

(*

The GC_BLOCK has 3 limits:

1)it can't be cur_trans : wrong

2)it can't be cur_data : wrong

3)it can't be in the fbq

*)

Fixpoint lookfor_gc_block (f:FTL) (count:nat) (num:nat) (t:gc_block_type):option nat :=
  do fbq <-- Some (ftl_free_blocks f);
  match count with
          | O  => None
          | S count' =>
            match fbq_in fbq num  with
              | true => match num with
                      | 15 => lookfor_gc_block f  count' 0 t
                      | _ =>  lookfor_gc_block f  count' (S num) t
                        end
              | false =>
                match check_valid_gc_block f t num with
                  | Some true => ret num
                  | _ => match num with
                               | 15 => lookfor_gc_block f  count' 0 t
                               | _ =>  lookfor_gc_block f  count' (S num) t
                             end
                end
            end
 end.

Definition gc_data_copy_trans_page(c:chip)(f:FTL)(lpn:page_no)(trans_pbn:block_no)(trans_off:nat)(pbn:block_no)(off:nat): option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  do d <-- read_block c trans_pbn trans_off;
  match d with
    | metabyte _ => None
    | metarecord meta_list => do new_list <-- copy_data_trans meta_list lpn (trans_data lpn pbn off);
                              do cur_bi <-- bit_get bit cur_trans;
                              do gtd_loc <-- gtd_look_by_lpn gtd lpn;
                              do cur_off <-- Some (bi_used_pages cur_bi);
                              do [c',bi'] <-- write_data_block c cur_bi cur_trans cur_off (metarecord new_list) (Some(gtd_loc, 0)) (ps_trans gtd_loc);
                              do bit' <-- bit_update bit cur_trans bi';
                              (*Invalide the old trans page*)
                              do bit'' <-- invalid_old_page bit' trans_pbn trans_off;
                              (*Invalidate the old data one*)
                              match find_meta_trans_record meta_list lpn 0 with
                                | None =>  (* update the gtd,find the gtd_loc *)
                                           do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_off);
                                           ret (c',(mk_FTL bit'' fbq cmt  gtd' cur_data cur_trans ) )

                                | Some i => do [old_data,old_off] <--  get_meta_trans_record meta_list lpn i;
                                            do bit''' <-- invalid_old_page bit'' old_data old_off;
                                            (* update the gtd,find the gtd_loc *)
                                            do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_off);
                                            ret (c',(mk_FTL bit''' fbq cmt  gtd' cur_data cur_trans ) )
                             end

end.

Definition gc_trans_in_gc_data (c:chip) (f:FTL) :option (prod chip FTL) :=
   let cur_trans := current_trans_block f in
   do cur_trans_bi <-- bit_get (ftl_bi_table f) cur_trans ;
   match check_block_is_full cur_trans_bi with
                     | false => ret (c,f)
                     | true =>do pbn <-- lookfor_gc_block f PAGES_PER_BLOCK 0 gc_trans_block ;
                              do [newc,newf] <-- gc_trans c f pbn;
                               ret (newc,newf)
  end.

Definition gc_data_copy_and_update (c:chip) (f:FTL) (pbn:block_no) (off:nat) (lpn:page_no): option (prod chip FTL) :=
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  do [pbn_off,cf] <-- gc_copy_data_page c f pbn off lpn;
  do [c',f'] <-- Some cf;
  do [new_data,new_off] <-- Some pbn_off;
  do cmt <-- Some ( ftl_cmt_table f');
  (* Have a bug <-- Done *)
  match gtd_get_trans_by_lpn gtd lpn with
      | Some _ =>(* maybe it is not in the trans page *)
                 do [old_trans,old_off] <-- gtd_get_trans_by_lpn gtd lpn;
                  (*update the corrsponding trans_page and gtd *)
                 (* TODO *)
                 do [newc,newf] <-- gc_trans_in_gc_data c' f';
                 do [c'',f''] <-- gc_data_copy_trans_page newc newf lpn old_trans old_off new_data new_off;
                 (* update the cmt *)
                 do cmt' <-- Some (ftl_cmt_table f'');
                 match cmt_in cmt lpn with
                      | false =>   ret (c'',f'')
                      | true => do loc <-- find_cmtrecord cmt' lpn 0;
                                do cmt'' <-- cmt_set cmt' loc (cmt_trans lpn new_data new_off clean);
                                do f''' <-- (ftl_update_cmt f'' cmt'');
                                ret (c'',f''')
                 end
      | _ =>    match cmt_in cmt lpn with
                      | false =>   ret (c',f')
                      | true => do loc <-- find_cmtrecord cmt lpn 0;
                                do cmt' <-- cmt_set cmt loc (cmt_trans lpn new_data new_off clean);
                                do f'' <-- (ftl_update_cmt f' cmt');
                                ret (c',f'')
                end
  end.

Fixpoint  gc_data_page(c:chip) (f:FTL) (pbn:block_no) (i:nat) :option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  do bi <-- bit_get bit pbn;
  do pst <-- Some ( bi_page_state bi );
  match i with
      | O => do bit' <-- invalid_old_block bit pbn;
             ret(c,(mk_FTL bit fbq cmt gtd cur_data cur_trans) )

      | S i' =>  do ps <-- pst_get pst i';
                 match ps with
                    | ps_data lpn =>  do [c',f'] <-- gc_data_copy_and_update c f pbn i' lpn;
                                      gc_data_page c' f' pbn i'

                    | _ =>  gc_data_page c f pbn i'

                 end
   end.

Definition gc_data(c:chip) (f:FTL) (pbn:block_no) :option (prod chip FTL) :=
  do [cur_data,cf] <-- alloc_gc_block c f;
  do [c',f'] <-- Some cf;
  do bit <-- Some (ftl_bi_table f');
  do bi <-- bit_get bit cur_data;
  do bi' <-- Some (bi_set_state bi bs_data);
  do bit' <-- bit_update bit cur_data bi';
  (* it still have a probelm --> Done *)
  do f'' <-- ftl_update_cur_data f' cur_data;
  do f''' <-- ftl_update_bit f'' bit';
  (*GC*)
  do [c'',f4] <-- gc_data_page c' f''' pbn PAGES_PER_BLOCK;
  (* enter_free_blocks *)
  do bit'' <-- Some (ftl_bi_table f4);
  do fbq <-- Some (ftl_free_blocks f4);
  do [bit''',fbq'] <-- free_block bit'' fbq pbn;
  do f5 <-- ftl_update_bit f4 bit''';
  do f6 <-- ftl_update_fbq f5 fbq';
  ret (c'',f6).

(*

The GC Opertions

The pbn has 3 limits:

1)it can't be cur_trans

2)it can't be cur_data

3)it can't be in the fbq

*)

Definition gc(c:chip) (f:FTL) (flag:alloc_block_type): option (prod chip FTL) :=
  match flag with
      | alloc_trans_block => do pbn <-- lookfor_gc_block f PAGES_PER_BLOCK 0 gc_trans_block;
                             do [c',f'] <--gc_trans c f pbn;
                             ret (c',f')

      | alloc_data_block =>  do pbn <-- lookfor_gc_block f PAGES_PER_BLOCK 0 gc_data_block;
                             do [c',f'] <--gc_data c f pbn;
                             ret (c',f')
  end.

Definition alloc_block (c: chip) (f: FTL) (flag:alloc_block_type) : option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  match (check_freebq_count fbq) with
    | fbqs_abundant =>
        do bs_status <-- Some (set_alloc_block_status flag);
        do [b, fbq'] <-- fbq_deq fbq;
        do bi_free <-- bit_get bit b;
        match bi_state bi_free with
          | bs_erased =>
              (* TODO:  we don't need to update bit. No,we need,we set the used_pages and pages_state *)
              do bit' <-- bit_update bit b (mk_bi bs_status 0 (bi_erase_count bi_free) (pst_set_all ps_erased));
              match flag with
                  | alloc_trans_block => ret (c, (mk_FTL bit'  fbq' (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) b ))
                  | alloc_data_block => ret (c, (mk_FTL bit'  fbq' (ftl_cmt_table f) (ftl_gtd_table f) b (current_trans_block f )))
              end
          | bs_invalid =>
              do c' <-- nand_erase_block c b;
              do bit' <-- bit_update bit b (mk_bi bs_status 0 (1 + bi_erase_count bi_free) (pst_set_all ps_erased));
              match flag with
                  | alloc_trans_block => ret (c',(mk_FTL bit' fbq' (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) b ))
                  | alloc_data_block =>  ret (c',(mk_FTL bit' fbq' (ftl_cmt_table f) (ftl_gtd_table f) b (current_trans_block f)))
              end
          | bs_data => None

          | bs_trans => None
        end

    | _ =>  do [c',f'] <-- gc c f flag;
            ret (c',f')
  end.

(* ******************************************************************************
* copy the trans_page_data(trans_pbn,trans_off) to current block  page or new allock page
  for updating the pbn off
*)

Definition copy_trans_page(c:chip)(f:FTL)(lpn:page_no)(trans_pbn:block_no)(trans_off:nat)(pbn:block_no)(off:nat): option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  do d <-- read_block c trans_pbn trans_off;
  match d with
    | metabyte _ => None
    | metarecord meta_list => do new_list <-- copy_data_trans meta_list lpn (trans_data lpn pbn off);
                              do cur_bi <-- bit_get bit cur_trans;
                              do gtd_loc <-- gtd_look_by_lpn gtd lpn;
                              match check_block_full cur_bi with
                                | true =>(* If it is full *)
                                         do cfx <-- alloc_block c f alloc_trans_block;
                                         do [c',f'] <-- Some cfx;
                                         do new_trans <-- Some (current_trans_block f');
                                         do bi <-- bit_get (ftl_bi_table f') new_trans;
                                         do new_trans_off <-- Some (bi_used_pages bi);
                                         (* Repeat *)
                                         do [c'',bi'] <-- write_data_block c' bi new_trans new_trans_off (metarecord new_list) (Some (gtd_loc, 0)) (ps_trans gtd_loc);
                                         do bit' <-- bit_update (ftl_bi_table f') new_trans bi';
                                         (*Invalidate the old trans one*)
                                         do bit'' <-- invalid_old_page bit' trans_pbn trans_off;
                                         (*Invalidate the old data one*)
                                         match find_meta_trans_record meta_list lpn 0 with
                                             | None =>  (* update the gtd *)
                                                        do gtd' <-- gtd_set gtd gtd_loc (gtd_trans new_trans new_trans_off) ;
                                                        ret(c'',(mk_FTL bit'' (ftl_free_blocks f') (ftl_cmt_table f') gtd' cur_data new_trans) )

                                             | Some i => do [old_data,old_off] <--  get_meta_trans_record meta_list lpn i;
                                                         do bit''' <-- invalid_old_page bit'' old_data old_off;
                                                         do gtd' <-- gtd_set gtd gtd_loc (gtd_trans new_trans new_trans_off) ;
                                                         ret(c'',(mk_FTL bit''' (ftl_free_blocks f') (ftl_cmt_table f') gtd' cur_data new_trans) )
                                        end

                                | false =>
                                           do cur_off <-- Some (bi_used_pages cur_bi);
                                           do [c',bi'] <-- write_data_block c cur_bi cur_trans cur_off (metarecord new_list) (Some(gtd_loc, 0)) (ps_trans gtd_loc);
                                           do bit' <-- bit_update bit cur_trans bi';
                                           (*Invalide the old trans page*)
                                           do bit'' <-- invalid_old_page bit' trans_pbn trans_off;
                                           (*Invalidate the old data one*)
                                           match find_meta_trans_record meta_list lpn 0 with
                                             | None =>  (* update the gtd,find the gtd_loc *)
                                                        do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_off);
                                                        ret (c',(mk_FTL bit'' fbq cmt  gtd' cur_data cur_trans ) )

                                             | Some i => do [old_data,old_off] <--  get_meta_trans_record meta_list lpn i;
                                                         do bit''' <-- invalid_old_page bit'' old_data old_off;
                                                         (* update the gtd,find the gtd_loc *)
                                                         do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_off);
                                                         ret (c',(mk_FTL bit''' fbq cmt  gtd' cur_data cur_trans ) )
                                            end
                               end
end.

Definition write_trans_page(c:chip)(f:FTL)(lpn:page_no) (pbn:block_no)(off:nat): option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  do meta_list <-- Some (blank_dmt);
  do new_list <-- copy_data_trans meta_list lpn (trans_data lpn pbn off);
  do cur_bi <-- bit_get bit cur_trans;
  do gtd_loc <-- gtd_look_by_lpn gtd lpn;
  match check_block_full cur_bi with
       | true =>(* If it is full *)
             do cfx <-- alloc_block c f alloc_trans_block;
             do [c',f'] <-- Some cfx;
             do new_trans <-- Some (current_trans_block f');
             do bi <-- bit_get (ftl_bi_table f') new_trans;
             do new_trans_off <-- Some (bi_used_pages bi);
             (* Repeat *)
             do [c'',bi'] <-- write_data_block c' bi new_trans new_trans_off (metarecord new_list) (Some (gtd_loc, 0)) (ps_trans gtd_loc);
             do bit' <-- bit_update (ftl_bi_table f') new_trans bi';
             do gtd' <-- gtd_set gtd gtd_loc (gtd_trans new_trans new_trans_off) ;
             ret(c'',(mk_FTL bit' (ftl_free_blocks f') (ftl_cmt_table f') gtd' cur_data new_trans) )

       | false =>
            do cur_off <-- Some (bi_used_pages cur_bi);
            do [c',bi'] <-- write_data_block c cur_bi cur_trans cur_off (metarecord new_list) (Some (gtd_loc, 0)) (ps_trans gtd_loc);
            do bit' <-- bit_update bit cur_trans bi';
            do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_off);
            ret (c',(mk_FTL bit' fbq cmt  gtd' cur_data cur_trans ) )
end.

Definition FTL_read(c:chip)(f:FTL)(lpn:page_no) : option (prod data (prod chip FTL) ) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  (* test valid_page_off off; *)
  (* If the lpn in the cmt *)
  test bvalid_logical_page_no lpn;
  match find_cmtrecord cmt lpn 0 with
      | Some num =>
                  (* Do the read change the priitoty *)
                  do record <-- cmt_get cmt num;
                  match record with
                   | cmt_empty => None
                   | cmt_trans lpn' pbn' off' flag' =>
                                              match find_empty_cmt cmt 0 with
                                                  | None =>  do cmt' <-- Some (remove_cmt cmt lpn);
                                                             do cmt'' <-- Some (append_tail cmt' record);
                                                             do d <-- read_block c pbn' off';
                                                             ret (d,(c,mk_FTL (ftl_bi_table f) (ftl_free_blocks f) cmt'' (ftl_gtd_table f) (current_data_block f) (current_trans_block f) ) )
                                                  | Some i => do cmt' <-- Some (remove_cmt cmt lpn);
                                                              do cmt'' <-- Some (insert_cmt cmt' record (pred i) );
                                                              do d <-- read_block c pbn' off';
                                                              ret (d,(c,mk_FTL (ftl_bi_table f) (ftl_free_blocks f) cmt'' (ftl_gtd_table f) (current_data_block f) (current_trans_block f) ) )
                                               end
                  end
      | None => do gtd_loc <-- gtd_look_by_lpn gtd lpn;
                do gtd_record <-- gtd_get gtd gtd_loc;
                match gtd_record with
                   | gtd_empty => ret (zero_page,(c,f))
                   | gtd_trans trans_lbn trans_offset =>
                             do [data,oob] <-- nand_read_page c trans_lbn trans_offset;
                             match data with
                                   | metabyte _ => None
                                   | metarecord meta_trans_list =>do [data_pbn,data_off] <-- find_trans_in_metatrans meta_trans_list lpn;
                                                                  match find_empty_cmt cmt 0 with
                                                                    | Some i =>(* Thec cmt is not full ,still have empty location *)
                                                                               (* If find the empty the empty must in the end,cmt_set and append_tail is both ok *)
                                                                               do newcmt <-- cmt_set cmt i (cmt_trans lpn data_pbn data_off clean);
                                                                               do d <-- read_block c data_pbn data_off;
                                                                               ret (d,(c,mk_FTL (ftl_bi_table f) (ftl_free_blocks f) newcmt (ftl_gtd_table f) (current_data_block f) (current_trans_block f)))

                                                                    | None =>  (*If it doesn't find the empty,the cmt is full *)
                                                                               do head <-- cmt_get cmt 0;
                                                                               match head with
                                                                                | cmt_trans h_lpn h_pbn h_off flag'' =>
                                                                                match flag'' with
                                                                                | clean =>
                                                                                do newcmt' <-- remove_head cmt;
                                                                                do newcmt'' <-- Some (append_tail newcmt' (cmt_trans lpn data_pbn data_off clean) );
                                                                                do d <-- read_block c data_pbn data_off;
                                                                                ret (d,(c,mk_FTL (ftl_bi_table f) (ftl_free_blocks f) newcmt'' (ftl_gtd_table f) (current_data_block f) (current_trans_block f)))
                                                                                | drity =>
                                                                                (* it is dirty *)
                                                                                (*find the the trans_page for h_lpn *)
                                                                                do newcmt' <-- remove_head cmt;
                                                                                do newcmt'' <-- Some (append_tail newcmt' (cmt_trans lpn data_pbn data_off clean) );
                                                                                do newf <-- ftl_update_cmt f newcmt'';
                                                                                do d <-- read_block c data_pbn data_off;
                                                                                match gtd_get_trans_by_lpn gtd h_lpn with
                                                                                | Some _ =>
                                                                                do [h_trans_pbn,h_trans_off] <-- gtd_get_trans_by_lpn gtd h_lpn;
                                                                                do [c',f'] <-- copy_trans_page c newf h_lpn h_trans_pbn h_trans_off h_pbn h_off;
                                                                                ret (d,(c', f'))
                                                                                | None =>
                                                                                do [c',f'] <-- write_trans_page c newf h_lpn h_pbn h_off;
                                                                                ret (d,(c',f'))
                                                                                end
                                                                                end
                                                                                | cmt_empty => None
                                                                               end

                                                                    end

                                end
                  end
end.

Definition cmt_update_when_ftl_write(c:chip) (f:FTL) (lbn:block_no) (loff:nat):option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  let lpn := lbn * PAGES_PER_BLOCK + loff in
  do bi <-- bit_get bit cur_data;
  do poff <-- Some (pred (bi_used_pages bi) );
  match find_cmtrecord cmt lpn 0 with
                     (* The cmt don't have the record *)
                     | None =>
                           match find_empty_cmt cmt 0 with
                                (* find the cmt is not full *)
                               | Some i => do cmt' <-- cmt_set cmt i (cmt_trans lpn cur_data poff dirty);
                                           ret (c,mk_FTL bit fbq cmt' gtd cur_data cur_trans)
                               | None  =>  do record <-- cmt_get cmt 0;
                                           match record with
                                               | cmt_empty => None
                                               | cmt_trans h_lpn h_pbn h_off h_flag =>
                                                       do cmt' <-- remove_head cmt;
                                                       do cmt'' <-- Some (append_tail cmt' (cmt_trans lpn cur_data poff dirty) );
                                                       match h_flag with
                                                           | clean =>  ret (c,mk_FTL bit fbq cmt'' gtd cur_data cur_trans)
                                                           | dirty =>  (*TO DO-->Done,This is not the invalid data*)
                                                                      match gtd_get_trans_by_lpn gtd h_lpn with
                                                                          | Some _ =>
                                                                                do [h_trans_pbn,h_trans_off] <-- gtd_get_trans_by_lpn gtd h_lpn;
                                                                                do new_f <-- Some (mk_FTL bit fbq cmt'' gtd cur_data cur_trans);
                                                                                do [c'',new_f'] <-- copy_trans_page c new_f  h_lpn h_trans_pbn h_trans_off h_pbn h_off;
                                                                                ret (c'',new_f')
                                                                          | None => (* The gtd loc is empty *)
                                                                                do f' <-- ftl_update_cmt f cmt'';
                                                                                do [c',f''] <-- write_trans_page c f' h_lpn h_pbn h_off;
                                                                                ret (c',f'')
                                                                       end
                                                       end
                                           end

                           end
                     (* It is in the cmt *)
                     | Some i => do record <-- cmt_get cmt i;
                                 do [old_pbn_off,cmt_flag] <-- cmt_get_trans record;
                                 (* The old data_one *)
                                 do [old_pbn,old_off] <-- Some old_pbn_off;
                                 (* do cmt' <-- cmt_set cmt i (cmt_trans lpn cur_data poff dirty); *)
                                 match find_empty_cmt cmt 0 with
                                     | None => do cmt' <-- Some (remove_cmt cmt lpn);
                                               do cmt'' <-- Some (append_tail cmt' (cmt_trans lpn cur_data poff dirty) );
                                               match cmt_flag with
                                                 | dirty => do bit' <-- invalid_old_page bit old_pbn old_off;
                                                           do new_f <-- Some (mk_FTL bit' fbq cmt'' gtd cur_data cur_trans);
                                                           ret (c,new_f)
                                                 | clean => (*TO DO-->Done,invalid is lazy*)
                                                            do new_f <-- Some (mk_FTL bit fbq cmt'' gtd cur_data cur_trans);
                                                            ret(c,new_f)
                                               end
                                    | Some empty_loc =>  do cmt' <-- Some (remove_cmt cmt  lpn);
                                                         do cmt'' <-- Some (insert_cmt cmt' (cmt_trans lpn cur_data poff dirty) (pred empty_loc) );
                                                          match cmt_flag with
                                                            | dirty => do bit' <-- invalid_old_page bit old_pbn old_off;
                                                                      do new_f <-- Some (mk_FTL bit' fbq cmt'' gtd cur_data cur_trans);
                                                                      ret (c,new_f)
                                                            | clean => (*TO DO-->Done,invalid is lazy*)
                                                                      do new_f <-- Some (mk_FTL bit fbq cmt'' gtd cur_data cur_trans);
                                                                      ret(c,new_f)
                                                           end
                                 end

    end.

Fixpoint get_lbnandoff_by_lpn (lpn:page_no) (num:nat) : option (prod nat nat) :=
 match num with
      | O  => None
      | S i'  => if ble_nat (i' * PAGES_PER_BLOCK) lpn then Some (i',(minus lpn (i' * PAGES_PER_BLOCK) ) ) else get_lbnandoff_by_lpn lpn i'
 end.

Definition FTL_write (c:chip) (f:FTL) (lpn:page_no) (d:data):option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  (* let lpn := lbn * PAGES_PER_BLOCK + loff in *)
  do [lbn,loff] <-- get_lbnandoff_by_lpn lpn BLOCKS;
  do bi <-- bit_get bit cur_data;
  do poff <-- Some (bi_used_pages bi);
  match check_block_is_full bi with
      (*It is not full*)
      | false => do [c',bi'] <-- write_data_block c bi cur_data poff d (Some (lbn,loff)) (ps_data lpn);
                 (* update the page_state in the bit *)
                 do bit' <-- bit_update bit cur_data bi';
                 do new_f <-- ftl_update_bit f bit';
                 do [new_c',new_f'] <-- cmt_update_when_ftl_write c' new_f lbn loff;
                 ret (new_c',new_f')
      | true  =>  do cfx <-- alloc_block c f alloc_data_block;
                  do [c',f'] <-- Some cfx;
                  do new_data <-- Some (current_data_block f');
                  do bi' <-- bit_get (ftl_bi_table f') new_data;
                  do new_data_off <-- Some (bi_used_pages bi');
                  do [c'',bi''] <-- write_data_block c' bi' new_data (new_data_off) d (Some (lbn, loff)) (ps_data lpn);
                  do bit' <-- bit_update (ftl_bi_table f') new_data bi'';
                  do new_f <-- Some (mk_FTL bit' (ftl_free_blocks f') (ftl_cmt_table f') (ftl_gtd_table f') new_data (current_trans_block f') );
                  (* update the cmt *)
                  do [new_c',new_f'] <-- cmt_update_when_ftl_write c'' new_f lbn loff;
                  ret (new_c',new_f')
 end.


From iris.program_logic Require Export weakestpre.
From iris.base_logic.lib Require Export invariants.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import excl.
Set Default Proof Using "Type".

Definition spawn : val :=
  λ: "f",
    let: "c" := ref NONE in
    Fork ("c" <- SOME ("f" #())) ;; "c".
Definition join : val :=
  rec: "join" "c" :=
    match: !"c" with
      SOME "x" => "x"
    | NONE => "join" "c"
    end.

(** The CMRA & functor we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class spawnG Σ := SpawnG { spawn_tokG :> inG Σ (exclR unitC) }.
Definition spawnΣ : gFunctors := #[GFunctor (exclR unitC)].

Instance subG_spawnΣ {Σ} : subG spawnΣ Σ → spawnG Σ.
Proof. solve_inG. Qed.

(** Now we come to the Iris part of the proof. *)
Section proof.
Context `{!heapG Σ, !spawnG Σ} (N : namespace).

Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
  (∃ lv, l ↦ lv ∗ (⌜lv = NONEV⌝ ∨
                   ∃ v, ⌜lv = SOMEV v⌝ ∗ (Ψ v ∨ own γ (Excl ()))))%I.

Definition join_handle (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
  (∃ γ, own γ (Excl ()) ∗ inv N (spawn_inv γ l Ψ))%I.

Global Instance spawn_inv_ne n γ l :
  Proper (pointwise_relation val (dist n) ==> dist n) (spawn_inv γ l).
Proof. solve_proper. Qed.
Global Instance join_handle_ne n l :
  Proper (pointwise_relation val (dist n) ==> dist n) (join_handle l).
Proof. solve_proper. Qed.

(** The main proofs. *)
Lemma spawn_spec (Ψ : val → iProp Σ) e (f : val) :
  to_val e = Some f →
  {{{ WP f #() {{ Ψ }} }}} spawn e {{{ l, RET #l; join_handle l Ψ }}}.
Proof.
  iIntros (<-%of_to_val Φ) "Hf HΦ". rewrite /spawn /=.
  wp_let. wp_alloc l as "Hl". wp_let.
  iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
  iMod (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?".
  { iNext. iExists NONEV. iFrame; eauto. }
  wp_apply wp_fork; simpl. iSplitR "Hf".
  - wp_seq. iApply "HΦ". rewrite /join_handle. eauto.
  - wp_bind (f _). iApply (wp_wand with "Hf"); iIntros (v) "Hv".
    iInv N as (v') "[Hl _]" "Hclose".
    wp_store. iApply "Hclose". iNext. iExists (SOMEV v). iFrame. eauto.
Qed.

Lemma join_spec (Ψ : val → iProp Σ) l :
  {{{ join_handle l Ψ }}} join #l {{{ v, RET v; Ψ v }}}.
Proof.
  iIntros (Φ) "H HΦ". iDestruct "H" as (γ) "[Hγ #?]".
  iLöb as "IH". wp_rec. wp_bind (! _)%E. iInv N as (v) "[Hl Hinv]" "Hclose".
  wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
  - iMod ("Hclose" with "[Hl]"); [iNext; iExists _; iFrame; eauto|].
    iModIntro. wp_match. iApply ("IH" with "Hγ [HΦ]"). auto.
  - iDestruct "Hinv" as (v') "[% [HΨ|Hγ']]"; simplify_eq/=.
    + iMod ("Hclose" with "[Hl Hγ]"); [iNext; iExists _; iFrame; eauto|].
      iModIntro. wp_match. by iApply "HΦ".
    + iDestruct (own_valid_2 with "Hγ Hγ'") as %[].
Qed.
End proof.

Typeclasses Opaque join_handle.


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

(**********************************************************************)
(*                   SF-Calculus                                      *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                   SF_tactics.v                                     *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Test.
Require Import General.
Require Import SF_Terms.

Definition termred := SF -> SF -> Prop.

Definition preserve (R : termred) (P : SF -> Prop) :=
  forall x : SF, P x -> forall y : SF, R x y -> P y.

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: SF-> SF -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Inductive sequential : termred -> termred -> termred :=
  | seq_red : forall (red1 red2 : termred) M N P,
                red1 M N -> red2 N P -> sequential red1 red2 M P.

Hint Resolve zero_red succ_red seq_red
.

Definition reflective red := forall (M: SF), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Lemma refl_seq : forall (red1 red2: termred),
                   reflective red1 -> reflective red2 -> reflective(sequential red1 red2).
Proof. red; split_all; eapply2 seq_red. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| |- reflective (sequential _) => eapply2 refl_seq; reflect
| |- sequential _ _ _ _ => try (eapply2 refl_seq)
| _ => split_all
end.

Ltac one_step :=
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try red; try reflect
end.

Ltac seq_l :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with N; auto; red; reflect
end.

Ltac seq_r :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with M; auto; red; reflect
end.

Definition transitive red := forall (M N P: SF), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Lemma preserves_app_multi_step : forall (red: termred), reflective red -> preserves_app red -> preserves_app (multi_step red).
Proof.
red. induction 3; split_all. generalize H0; induction 1.
reflect.
apply succ_red with (App M N); auto.
assert( transitive (multi_step red)) by eapply2 transitive_red.
apply X0 with (App N0 N); auto.
one_step.
Qed.

Lemma preserves_app_seq : forall (red1 red2: termred), preserves_app red1 -> preserves_app red2 -> preserves_app (sequential red1 red2).
Proof.
red; split_all.
inversion H1; inversion H2.
apply seq_red with (App N0 N1); auto.
Qed.

Hint Resolve preserves_app_multi_step preserves_app_seq .

Ltac eelim_for_equal :=
match goal with
| H: forall _, _ = _ -> _  |- _ => eelim H; clear H; subst; eelim_for_equal
| _ => split_all
end.

Ltac inv1 prop :=
match goal with
| H: prop (Ref _) |- _ => inversion H; clear H; inv1 prop
| H: prop (App  _ _) |- _ => inversion H; clear H; inv1 prop
| H: prop Op _ |- _ => inversion H; clear H; inv1 prop
| _ => split_all
 end.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.
Lemma implies_red_seq:
 forall red1 red2 red3,
  implies_red red1  (multi_step red3)  ->
  implies_red red2 (multi_step red3) ->
  implies_red (sequential red1 red2) (multi_step red3) .
Proof.
red; split_all. inversion H1. apply transitive_red with N0; auto.
Qed.

Definition subst_preserves_l (red: termred) :=
forall (M M' N : SF), red M M' -> red  (subst M N) (subst M' N).

Definition subst_preserves_r (red: termred) :=
forall (M N N' : SF), red N N' -> red  (subst M N) (subst M N').

Definition subst_preserves (red: termred) :=
forall (M M' : SF), red M M' -> forall N N', red N N' ->
red  (subst M N) (subst M' N').

Lemma subst_preserves_l_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_l (multi_step red).
Proof. unfold subst_preserves_l.
 induction 2; split_all.
apply succ_red with (subst N0 N); auto.
Qed.

Lemma subst_preserves_r_multi_step :
forall (red: termred), subst_preserves_r red -> subst_preserves_r (multi_step red).
Proof. unfold subst_preserves_r.
 induction 2; split_all.
apply succ_red with (subst M N); auto.
Qed.

Lemma subst_preserves_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_r red -> subst_preserves (multi_step red).
Proof.
unfold subst_preserves. split_all.
assert(transitive (multi_step red)) by eapply2 transitive_red.
unfold transitive in *.
apply X with  (subst M' N); auto.
eapply2 subst_preserves_l_multi_step.
eapply2 subst_preserves_r_multi_step.
Qed.

Ltac inv red :=
match goal with
| H: multi_step red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Op _) _ |- _ => inversion H; clear H; inv red
| H: red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: red (Op _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Op _) |- _ => inversion H; clear H; inv red
| H: red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: red _ (Op _) |- _ => inversion H; clear H; inv red
| _ => subst; split_all
 end.

Definition diamond (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_flip: forall red1 red2, diamond red1 red2 -> diamond red2 red1.
Proof. unfold diamond; split_all. elim (H M P H1 N H0); split_all. exist x. Qed.

Lemma diamond_strip :
forall red1 red2, diamond red1 red2 -> diamond red1 (multi_step red2).
Proof. intros.
eapply2 diamond_flip.
red; induction 1; split_all.
exist P.
elim (H M P0 H2 N); split_all.
elim(IHmulti_step H x); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Definition diamond_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond_star_strip: forall red1 red2, diamond_star red1 red2 -> diamond (multi_step red2) red1 .
Proof.
red. induction 2; split_all.
exist P.
elim(H M P0 H2 N H0); split_all.
elim(IHmulti_step H x); split_all.
exist x0.
apply transitive_red with x; auto.
Qed.

Lemma diamond_tiling :
forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
red.  induction 2; split_all.
exist P.
elim(diamond_strip red red2 H M N H0 P0); split_all.
elim(IHmulti_step H x H4); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond_tiling.

Lemma diamond_seq: forall red red1 red2, diamond red red1 -> diamond red red2 -> diamond red (sequential red1 red2).
Proof. unfold diamond; split_all.
inversion H2.
elim(H M N H1 N0); split_all.
elim(H0 N0 x H11 P); split_all.
exist x0.
apply seq_red with x; auto.
Qed.

Lemma relocate_null :
forall (n n0 : nat), relocate n n0 0 = n.
Proof. split_all. unfold relocate. case (test n0 n); intro; auto with arith. Qed.

Lemma relocate_lessthan : forall m n k, m<=k -> relocate k m n = (n+k).
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.
Lemma relocate_greaterthan : forall m n k, m>k -> relocate k m n = k.
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.

Ltac relocate_lt :=
try (rewrite relocate_lessthan; [| omega]; relocate_lt);
try (rewrite relocate_greaterthan; [| omega]; relocate_lt);
try(rewrite relocate_null).

Lemma relocate_zero_succ :
forall n k, relocate 0 (S n) k = 0.
Proof.  split_all. Qed.

Lemma relocate_succ :
forall n n0 k, relocate (S n) (S n0) k = S(relocate n n0 k).
Proof.
intros; unfold relocate. elim(test(S n0) (S n)); elim(test n0 n); split_all.
noway.
noway.
Qed.

Lemma relocate_mono : forall M N n k, relocate M n k = relocate N n k -> M=N.
Proof.
intros M N n k.
unfold relocate.
elim(test n M); elim(test n N); split_all; omega.
Qed.

Fixpoint rank (M: SF) :=
match M with
| Ref _ => 1
| Op _ => 1
| App M1 M2 => S((rank M1) + (rank M2))
end.

Lemma rank_positive: forall M, rank M > 0.
Proof.
induction M; split_all; try omega.
Qed.

Ltac rank_tac := match goal with
| |- forall M, ?P  =>
cut (forall p M, p >= rank M -> P ); [ intros H M;  eapply2 H |
intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
]
end .


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf.

Require Import List. Import ListNotations.
Require Import Strings.String.

Definition irred e : Prop := forall b, ~(step e b).

Notation "Γ ⊢ E ⇒ A" := (Typing Γ E Inf A) (at level 45).
Notation "Γ ⊢ E ⇐ A" := (Typing Γ E Chk A) (at level 45).

Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0).
Notation "t ^^ u"       := (open_exp_wrt_exp t u) (at level 67).
Notation "e ^ x"        := (open_exp_wrt_exp e (e_var_f x)).

Notation "v ~-> A v'" := (TypedReduce v A v') (at level 68).

Notation "t ->* r" := (steps t r) (at level 68).
Notation "t ->** r" := (gsteps t r) (at level 68).

Lemma star_one:
forall a b, step a (Expr b) -> steps a (Expr b).
Proof.
eauto using steps.
Qed.

Lemma star_trans:
forall a b, steps a (Expr b) -> forall c, steps b (Expr c) -> steps a (Expr c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Lemma gstar_one:
forall a b, gstep a (Expr b) -> gsteps a (Expr b).
Proof.
eauto using steps.
Qed.

Lemma gstar_trans:
forall a b, gsteps a (Expr b) -> forall c, gsteps b (Expr c) -> gsteps a (Expr c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Lemma gstar_transb:
forall a b, gsteps a (Expr b) -> gsteps b Blame -> gsteps a Blame.
Proof.
  introv red1 red2.
  inductions red1; eauto using gsteps.
Qed.

Hint Resolve star_one star_trans gstar_one gstar_trans gstar_transb : core.

(** [x # E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Definition env := list (atom * exp).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  let E := gather_atoms_with (fun x : ctx => dom x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  constr:(A `union` B `union` C `union` D `union` F).

Lemma ssvalue_lc : forall v,
    ssval v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
Qed.

Lemma value_lc : forall v,
    value v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
  forwards*: ssvalue_lc H.
Qed.

Lemma walue_lc : forall v,
    walue v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
  forwards*: value_lc H.
Qed.

Lemma val_wal : forall v,
    value v ->  walue v.
Proof.
  introv H.
  induction* H.
Qed.

Hint Resolve value_lc ssvalue_lc val_wal : core.

Lemma ssvalue_blame: forall (v:exp),
    ssval v -> not(step v Blame).
Proof.
  introv sval.
  unfold not;intros nt.
  inductions sval;inverts nt;
  try solve[destruct E; unfold simpl_fill in H0; inverts* H0].
  -
  inverts H1; try solve[destruct E; unfold simpl_fill in H0; inverts* H0].
  -
  inverts H4; try solve[destruct E; unfold simpl_fill in H0; inverts* H0].
  -
  destruct E; unfold simpl_fill in H; inverts* H.
  -
  destruct E; unfold simpl_fill in H; inverts* H.
Qed.

Lemma step_not_value: forall (v:exp),
    value v -> irred v.
Proof.
  introv.
  unfold irred.
  inductions v; introv H;
  inverts* H;
  unfold not;intros.
  - inverts* H; try solve[inverts H1].
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    forwards*:ssvalue_blame H4.
    inverts* H5.
    inverts H1;inverts* H3.
    inverts H1;inverts* H3.
Qed.

Lemma step_not_walue: forall (v:exp),
    walue v -> irred v.
Proof.
  introv wal.
  unfold irred.
  inductions wal; intros.
  forwards*: step_not_value H.
  unfold not; intros nt; inverts* nt;
  destruct E; unfold simpl_fill in H0; inverts* H0.
Qed.

Lemma sfill_appl : forall e1 e2,
  (e_app e1 e2) = (simpl_fill (sappCtxL e2) e1).
Proof.
  intros. eauto.
Qed.

Lemma sfill_appr : forall e1 e2,
  (e_app e1 e2) = (simpl_fill (sappCtxR e1) e2).
Proof.
  intros. eauto.
Qed.

Lemma sfill_addl : forall e1 e2,
  (e_add e1 e2) = (simpl_fill (saddCtxL e2) e1).
Proof.
  intros. eauto.
Qed.

Lemma sfill_addr : forall e1 e2,
  (e_add e1 e2) = (simpl_fill (saddCtxR e1) e2).
Proof.
  intros. eauto.
Qed.

Lemma sfill_prol : forall e1 e2,
  (e_pro e1 e2) = (simpl_fill (sproCtxL e2) e1).
Proof.
  intros. eauto.
Qed.

Lemma sfill_pror : forall e1 e2,
  (e_pro e1 e2) = (simpl_fill (sproCtxR e1) e2).
Proof.
  intros. eauto.
Qed.

Lemma sfill_l : forall e1,
  (e_l e1) = (simpl_fill (slCtx) e1).
Proof.
  intros. eauto.
Qed.

Lemma sfill_r : forall e1,
(e_r e1) = (simpl_fill (srCtx) e1).
Proof.
  intros. eauto.
Qed.

Lemma multi_red_app : forall v t t',
    walue v -> t ->* (Expr t') -> (e_app v t) ->* (Expr (e_app v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  -
  assert(simpl_wf (sappCtxR v)). eauto.
  forwards*: do_step H0 H.
  -
  forwards*: IHRed.
  assert(simpl_wf (sappCtxR v)). eauto.
  forwards*: do_step H1 H.
Qed.

Lemma multi_red_app2 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* (Expr t1') -> (e_app t1 t2) ->* (Expr (e_app t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  -
  assert(simpl_wf (sappCtxL t2)). eauto.
  forwards*: do_step H0 H.
  -
  assert(simpl_wf (sappCtxL t2)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma wmulti_red_pro : forall v t t',
    walue v -> t ->* (Expr t') -> (e_pro v t) ->* (Expr (e_pro v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  -
  assert(simpl_wf (sproCtxR v)). eauto.
  forwards*: do_step H0 H.
  -
  forwards*: IHRed.
  assert(simpl_wf (sproCtxR v)). eauto.
  forwards*: do_step H1 H.
Qed.

Lemma multi_red_pro : forall v t t',
    value v -> t ->* (Expr t') -> (e_pro v t) ->* (Expr (e_pro v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  -
  assert(simpl_wf (sproCtxR v)). eauto.
  forwards*: do_step H0 H.
  -
  forwards*: IHRed.
  assert(simpl_wf (sproCtxR v)). eauto.
  forwards*: do_step H1 H.
Qed.

Lemma multi_red_pro2 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* (Expr t1') -> (e_pro t1 t2) ->* (Expr (e_pro t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  -
  assert(simpl_wf (sproCtxL t2)). eauto.
  forwards*: do_step H0 H.
  -
  assert(simpl_wf (sproCtxL t2)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma multi_red_l : forall t1 t1',
     t1 ->* (Expr t1') -> (e_l t1) ->* (Expr (e_l t1')).
Proof.
  introv Red.
  inductions Red; eauto.
  -
  assert(simpl_wf (slCtx)). eauto.
  forwards*: do_step H0 H.
  -
  assert(simpl_wf (slCtx)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma multi_red_r : forall t1 t1',
     t1 ->* (Expr t1') -> (e_r t1) ->* (Expr (e_r t1')).
Proof.
  introv Red.
  inductions Red; eauto.
  -
  assert(simpl_wf (srCtx)). eauto.
  forwards*: do_step H0 H.
  -
  assert(simpl_wf (srCtx)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma step_not_ssval: forall e e',
 step e (Expr e') ->
 not(ssval e').
Proof.
  introv red.
  inductions red; try solve[unfold not;intros nt;inverts* nt].
  -
  destruct E; unfold simpl_fill;unfold not;intros nt;inverts* nt.
  -
  unfold not;intros nt;inverts* nt.
  inverts red; try solve[
    destruct E; unfold simpl_fill in *;inverts* H0
  ].
  inverts* H2.
  -
  inverts* H0.
  unfold not;intros nt;inverts* nt; try solve[inverts H3].
  -
  inverts H.
  unfold not;intros nt;inverts* nt; try solve[inverts H2].
  inverts H2. inverts H4.
  -
  inverts H.
  unfold not;intros nt;inverts* nt; try solve[inverts H2].
  inverts H2. inverts H5.
  (* -
  unfold not;intros nt;inverts* nt; try solve[inverts H2].
  -
  unfold not;intros nt;inverts* nt; try solve[inverts H2].
  inverts H0; inverts H3.
  inverts H1. *)
Qed.

Lemma multi_red_add : forall v t t',
    value v -> t ->* (Expr t') -> (e_add v t) ->* (Expr (e_add v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  -
  assert(simpl_wf (saddCtxR v)). eauto.
  forwards*: do_step H0 H.
  -
  assert(simpl_wf (saddCtxR v)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma multi_red_add2 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* (Expr t1') -> (e_add t1 t2) ->* (Expr (e_add t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  -
  assert(simpl_wf (saddCtxL t2)). eauto.
  forwards*: do_step H0 H.
  -
  assert(simpl_wf (saddCtxL t2)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma multi_red_anno : forall A t t',
    not (value (e_anno t A)) ->
    t ->* (Expr t') -> (e_anno t A) ->* (Expr (e_anno t' A)).
Proof.
  introv nt Red.
  inductions Red; eauto.
  assert(step (e_anno e A) (Expr (e_anno e' A))). eauto.
  forwards*: IHRed.
  unfold not; intros.
  apply nt.
  inverts H1.
  forwards*: step_not_ssval H.
Qed.

Lemma gmulti_red_app : forall v t t',
    gvalue v -> t ->** (Expr t') -> (e_app v t) ->** (Expr (e_app v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(wellformed (appCtxR v)). eauto.
  forwards*: gdo_step H1 H.
Qed.

Lemma multi_blame_app : forall v t,
    gvalue v -> t ->** (Blame) -> (e_app v t) ->** (Blame).
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply gstep_nb.
  assert(wellformed (appCtxR v)). eauto.
  forwards*: gdo_step H0 H.
  simpl. forwards*: IHRed.
  apply gstep_b.
  assert(wellformed (appCtxR v)). eauto.
  forwards*: gblame_step H0 H.
Qed.

Lemma gmulti_red_app2 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->** (Expr t1') -> (e_app t1 t2) ->** (Expr (e_app t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  assert(wellformed (appCtxL t2)). eauto.
  forwards*: gdo_step H0 H.
Qed.

Lemma multi_blame_app2 : forall t1 t2 ,
    lc_exp t2 -> t1 ->** Blame -> (e_app t1 t2) ->** Blame.
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply gstep_nb.
  assert(wellformed (appCtxL t2)). eauto.
  forwards*: gdo_step H0 H.
  simpl. forwards*: IHRed.
  apply gstep_b.
  assert(wellformed (appCtxL t2)). eauto.
  forwards*: gblame_step H0 H.
Qed.

Lemma gmulti_red_anno : forall A t t',
    t ->** (Expr t') -> (e_anno t A) ->** (Expr (e_anno t' A)).
Proof.
  introv Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(wellformed (annoCtx A)). eauto.
  forwards*: gdo_step H1 H.
Qed.

Lemma multi_blame_anno : forall t A ,
    t ->** Blame -> (e_anno t A) ->** Blame.
Proof.
  introv Red.
  inductions Red; eauto.
  eapply gstep_nb.
  assert(wellformed (annoCtx A)). eauto.
  forwards*: gdo_step H0 H.
  simpl. forwards*: IHRed.
  apply gstep_b.
  assert(wellformed (annoCtx A)). eauto.
  forwards*: gblame_step H0 H.
Qed.


Require Import List.
Import ListNotations.

Require Export Map.
Require Export Shared.

Definition var := nat.
Definition id := nat.
Definition qid := nat.
Definition loc := nat.

(*
======
Types
======
*)

Inductive ty : Type :=
  | TAct : ty
  | TBes : ty
  | TPas : ty
  | TArr : ty -> ty -> ty
  | TUnit: ty
.

Function is_active (t : ty) : bool :=
  match t with
    | TAct => true
    | TBes => true
    | _ => false
  end.

(*
============
Expressions
============
*)

Inductive expr : Type :=
  | EVar : var -> expr
  | EApp : expr -> expr -> expr
  | ESend : expr -> var -> ty -> expr -> expr
  | EMut : expr -> expr
  | ENew : ty -> expr
  | EBes : expr -> expr
  | EAtStart : expr -> expr
  | EAtEnd : expr -> expr
  | ELam : var -> ty -> expr -> expr
  | EUnit : expr
  | EId : id -> expr
  | ELoc : loc -> expr
  | EBId : loc -> id -> expr
.

Tactic Notation "expr_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "EVar"
  | Case_aux c "EApp"
  | Case_aux c "ESend"
  | Case_aux c "EMut"
  | Case_aux c "ENew"
  | Case_aux c "EBes"
  | Case_aux c "EAtStart"
  | Case_aux c "EAtEnd"
  | Case_aux c "ELam"
  | Case_aux c "EUnit"
  | Case_aux c "EId"
  | Case_aux c "ELoc"
  | Case_aux c "EBId"
].

Inductive is_val : expr -> Prop :=
  | LamIsVal : forall x t e, is_val (ELam x t e)
  | UnitIsVal : is_val EUnit
  | IdIsVal : forall id, is_val (EId id)
  | LocIsVal : forall l, is_val (ELoc l)
  | BIdIsVal : forall l id, is_val (EBId l id)
.

Definition econtext := expr -> expr.

Definition ctx_appl (e' : _) : econtext := (fun e => EApp e e').
Hint Unfold ctx_appl.
Definition ctx_appr (v : _) : econtext := (fun e => EApp v e).
Hint Unfold ctx_appr.
Definition ctx_send (x : _) (ty : _) (e' : _): econtext := (fun e => ESend e x ty e').
Hint Unfold ctx_send.
Definition ctx_mut : econtext := (fun e => EMut e).
Hint Unfold ctx_mut.
Definition ctx_bes : econtext := (fun e => EBes e).
Hint Unfold ctx_bes.
Definition ctx_atstart : econtext := (fun e => EAtStart e).
Hint Unfold ctx_atstart.
Definition ctx_atend : econtext := (fun e => EAtEnd e).
Hint Unfold ctx_atend.

Inductive is_econtext : econtext -> Prop :=
  | EC_AppL :
      forall e',
        is_econtext (ctx_appl e')
  | EC_AppR :
      forall v,
        is_val v ->
        is_econtext (ctx_appr v)
  | EC_Send :
      forall x t e,
        is_econtext (ctx_send x t e)
  | EC_Mut :
        is_econtext ctx_mut
  | EC_Bes :
        is_econtext ctx_bes
  | EC_AtStart :
        is_econtext ctx_atstart
  | EC_AtEnd :
        is_econtext ctx_atend
.

Fixpoint freeVars (e : expr) : list var :=
  match e with
    | EVar x => [x]
    | EApp e1 e2 => freeVars e1 ++ freeVars e2
    | ESend e1 x _ e2 => freeVars e1 ++ List.remove id_eq_dec x (freeVars e2)
    | EMut e' => freeVars e'
    | EBes e' => freeVars e'
    | EAtStart e' => freeVars e'
    | EAtEnd e' => freeVars e'
    | ELam x _ e' => List.remove id_eq_dec x (freeVars e')
    | _ => []
  end.

Fixpoint freeLocs (e : expr) : list loc :=
  match e with
    | ELoc l => [l]
    | EApp e1 e2 => freeLocs e1 ++ freeLocs e2
    | ESend e1 x _ e2 => freeLocs e1 ++ freeLocs e2
    | EMut e' => freeLocs e'
    | EBes e' => freeLocs e'
    | EAtStart e' => freeLocs e'
    | EAtEnd e' => freeLocs e'
    | ELam x _ e' => freeLocs e'
    | _ => []
  end.

Fixpoint freeIds (e : expr) : list id :=
  match e with
    | EId id => [id]
    | EApp e1 e2 => freeIds e1 ++ freeIds e2
    | ESend e1 x _ e2 => freeIds e1 ++ freeIds e2
    | EMut e' => freeIds e'
    | EBes e' => freeIds e'
    | EAtStart e' => freeIds e'
    | EAtEnd e' => freeIds e'
    | ELam x _ e' => freeIds e'
    | _ => []
  end.

Fixpoint freeBIds (e : expr) : list (loc * id) :=
  match e with
    | EBId l id => [(l, id)]
    | EApp e1 e2 => freeBIds e1 ++ freeBIds e2
    | ESend e1 x _ e2 => freeBIds e1 ++ freeBIds e2
    | EMut e' => freeBIds e'
    | EBes e' => freeBIds e'
    | EAtStart e' => freeBIds e'
    | EAtEnd e' => freeBIds e'
    | ELam x _ e' => freeBIds e'
    | _ => []
  end.

Fixpoint subst (x : var) (v : expr) (e : expr) : expr :=
  match e with
    | EVar y => if id_eq_dec x y then v else e
    | EApp e1 e2 => EApp (subst x v e1) (subst x v e2)
    | ESend e1 y t e2 =>
      ESend (subst x v e1) y t
            (if id_eq_dec x y
             then e2
             else subst x v e2)
    | EMut e' => EMut (subst x v e')
    | EBes e' => EBes (subst x v e')
    | EAtStart e' => EAtStart (subst x v e')
    | EAtEnd e'   => EAtEnd (subst x v e')
    | ELam y t e' =>
      ELam y t
           (if id_eq_dec x y then
              e'
            else
              (subst x v e'))
    | _ => e
  end.

(*
==============
Configuration
==============
*)

Inductive msg : Type :=
  | Msg : expr -> msg
  | Atomic : qid -> msg
  | EndAtomic : msg.

Definition localHeap := list loc.

Definition conversations := partial_map id qid.

Definition queue := list msg.

Definition actor := (loc * localHeap * conversations * queue * expr)%type.

Definition heap := list actor.

Definition heapExtend (H : heap) (a : actor) := snoc H a.

Hint Unfold heapExtend.

Definition heapLookup (H : heap) (id : id) :=
  nth_error H id.

Fixpoint heapUpdate (H : heap) (id : id) (a : actor) :=
  match H with
  | nil => nil
  | a' :: H' =>
    match id with
    | O    => a :: H'
    | S id' => a' :: (heapUpdate H' id' a)
    end
  end.

Definition LH (H : heap) (id : id) :=
  match heapLookup H id with
    | Some (_, L, _, _, _) => Some L
    | None => None
  end.

Hint Unfold LH.

Definition conv (H : heap) (id : id) :=
  match heapLookup H id with
    | Some (_, _, C, _, _) => Some C
    | None => None
  end.

Hint Unfold conv.

(*
--------------
Configuration
--------------
*)

Definition queueMap := partial_map qid (queue*id).

Inductive actor_idle (M : queueMap) : actor -> Prop :=
  | ActorIdle : forall l L C v, is_val v -> actor_idle M (l, L, C, [], v)
  | ActorBlocked :
      forall l L C q Q v id,
        is_val v ->
        M q = Some ([], id) ->
        actor_idle M (l, L, C, Atomic q::Q, v)
.

Definition heap_done (M : queueMap) := Forall (actor_idle M).

Definition configuration := (queueMap * heap * nat)%type.

Definition actor_done (cfg : configuration) (id : id) : Prop :=
  match cfg with
    | (M, H, _) => match heapLookup H id with
                     | Some a => actor_idle M a
                     | None => False
                   end
  end
.

Definition cfg_done (cfg : configuration) : Prop :=
  match cfg with
    | (M, H, _) => heap_done M H
  end
.


From Undecidability Require Import TM.Util.Prelim.
From Undecidability Require Import TM.Util.TM_facts TM.Compound.MoveToSymbol.

Require Import ssrbool Lia.
Lemma last_not_default X (d d':X) A :
  A <> [] -> last A d = last A d'.
Proof. induction A. easy. destruct A;cbn. easy. intros ?. now apply IHA. Qed.

Lemma removelast_as_tail X (x:list X): removelast x = rev (tail (rev x)).
Proof.
  rewrite tl_rev. symmetry. apply rev_involutive.
Qed.

Local Arguments removelast : simpl nomatch.
Local Arguments last : simpl nomatch.

(** TIPP: Look in ./Copy.v **)
(** I have no Idea anymore why i called this nicer ... *)

Definition MoveToSymbol_Rel_nice (sig':finType) (f:sig' -> bool) (g:sig' -> sig') t t' :=
  ((current t = None /\ t = t')
   \/ (exists t__L c t__R1 t__R2,
         t = midtape t__L c (t__R1++t__R2)
         /\ (forall x, x el (removelast (c::t__R1)) -> f x = false)
         /\ f (last (c::t__R1) c) = ssrbool.isSome (current t')
         /\ (t' = midtape (rev (map g (removelast (c::t__R1)))++t__L) (g (last (c::t__R1) c)) t__R2
            \/ (t' = rightof (g (last (c::t__R1) c)) (rev (map g (removelast (c::t__R1)))++t__L) /\ t__R2 = [])))).

Lemma MoveToSymbol_Fun_nice (sig':finType) (f:sig' -> bool) (g:sig' -> sig') t t' :
  MoveToSymbol_Fun f g t = t' <-> MoveToSymbol_Rel_nice f g t t'.
Proof.
  remember (tape_local t) as A eqn:eqA.
  revert t t' eqA. unfold MoveToSymbol_Rel_nice.
  induction A using (size_induction (f:=@length sig'));intros t t' eqA.
  rewrite MoveToSymbol_Fun_equation. destruct current eqn:eq.
  2:{ split. now left. intros [ | H']. easy. destruct H' as (?&?&?&?&->&?). easy. }
  destruct f eqn:Hf.
  { destruct t;inv eq. all:cbn. split.
    -intros <-. right. eexists _,_,[],_.
     repeat split;eauto.
     intros x Hx. destruct Hx.
    -intros [ | (t__L&c&t__R1&t__R2&[= -> -> -> ]&Hfalse&Hc&H'')];[ easy | ].
     destruct t__R1 as [ | c__R t__R1].
     2:{exfalso. cbn in *. rewrite Hfalse in Hf;auto. }
     cbn in *.
     destruct H'' as [-> | [-> -> ]]. all:cbn in *;now eauto + congruence.
  }
  destruct t. all:inv eq. destruct l0. all:cbn - [removelast].
  all:rewrite H;[ | | reflexivity];[cbn | cbn;nia].
  - cbn. split.
    +intros [(_&<-)| (?&?&?&?&[=]&?)];[]. right.
     eexists _,_,[],[]. split;[reflexivity| ]. split;[easy| ]. unfold last, removelast;cbn. eauto.
    +intros [([=]&?)|(t__L&c&t__R1&t__R2&[= <- <- H__nil]&Hfalse&Hc&H'')];[].
     destruct t__R1;[ |now inv H__nil]. destruct t__R2;[ |now inv H__nil]. clear H__nil.
     cbn in H''|-*. destruct H'' as [-> | [-> _ ]]. 2:now left. now unfold last in Hc;cbn in Hc;congruence.
  -eapply Morphisms_Prop.or_iff_morphism. easy.
   split. all:intros (t__L&c&t__R1&t__R2&Heq&Hfalse&Hc&H');revert Heq.
   +intros [= <- -> ->]. eexists _,_,(_::_),_. split. reflexivity.
    cbn. split. now intros ? [-> | ];eauto.
    autorewrite with list in |-*;cbn. erewrite last_not_default. split;now eauto. easy.
   +intros [= -> -> Heq]. destruct t__R1.
    {cbn in *. destruct H' as [ -> | [-> ->]]. all: now cbn in *;congruence. }
    revert Heq;intros [= -> ->].
    eexists (_::_),_,_,_. split. reflexivity. cbn in *.
    split. now eauto. autorewrite with list in H';cbn. erewrite last_not_default. 2:easy. split;now eauto.
Qed.

Lemma MoveToSymbol_Fun_is_rel (sig':finType) (f:sig' -> bool) (g:sig' -> sig') t :
  MoveToSymbol_Rel_nice f g t (MoveToSymbol_Fun f g t).
Proof.
  now rewrite <- MoveToSymbol_Fun_nice.
Qed.


Require Import List.
Require Import Arith.

(** * VM for "Virtual Machine" *)

Require Import CU.
Require Import FB.
Require Import Common.

Inductive code_pointer : Set :=
| CP_user : nat -> code_pointer
| CP_pap : nat -> code_pointer
| CP_cons : constructor -> nat -> code_pointer.

Definition eq_cp_dec : forall c d : code_pointer, {c = d} + {c <> d}.
Proof.
repeat decide equality.
Defined.

Inductive expr : Set :=
| App : var -> vars -> CU.cleanup -> expr
| Constr : constructor -> vars -> CU.cleanup -> expr
| Letrec : list (vars * code_pointer) -> expr -> expr
| Case : expr -> code_pointer -> expr.

Definition lambda_form := gen_lambda_form (Expr := expr).

Definition alt := gen_alt (Expr := code_pointer).

Definition alts := list alt.

Inductive cs_node : Set :=
| CS_expr : expr -> cs_node
| CS_alts : alts -> cs_node
| CS_lf : lambda_form -> cs_node
| CS_None.

Definition code_store := list (code_pointer * cs_node).

Fixpoint find_cs (cs : code_store) (cp : code_pointer) : cs_node :=
match cs with
| nil => CS_None
| (cp0, node) :: cs0 => if eq_cp_dec cp cp0
  then node
  else find_cs cs0 cp
end.

Definition closure := (code_pointer * addresses)%type.

Definition closures := list closure.

Definition heap := address -> option closure.

Inductive config : Set :=
| Config : heap -> expr -> env -> (argstack * FB.fake_bottom)
  -> address -> config
| Enter : heap -> address -> argstack * FB.fake_bottom -> env -> config.

Inductive ret_value : Set :=
| Val_con : heap -> constructor -> addresses -> ret_value
| Val_pap : heap -> address -> addresses -> ret_value.

Definition value := (ret_value * env * (argstack * FB.fake_bottom))%type.

Notation " << a , b , c , d , e >> " := (Config a b c d e) (at level 70).
Notation " << a , b , c , d >> " := (Enter a b c d) (at level 70).

Inductive action : Set :=
| E : config -> action
| A : value -> action.

Inductive stack_elem : Set :=
| K_alt : code_pointer -> FB.fake_bottom -> stack_elem
| K_upd : address -> FB.fake_bottom -> stack_elem.

Definition stack := list stack_elem.

Definition look_up (e : env) (g : heap) (p : address) (v : var)
  : option address :=
match v with
| B_ind n => nth n e
| C_ind n => match g p with Some (_, clo) => nth n clo | None => None end
end.

Fixpoint map_env (e : env) (g : heap) (a : address) (vs : vars) {struct vs}
  : option addresses :=
match vs with
| nil => Some nil
| x::xs =>
  match map_env e g a xs with
  | Some ps =>
    match look_up e g a x with
    | Some p => Some (p::ps)
    | None => None
    end
  | None => None
  end
end.

Definition set (g : heap) (a : address) (clo : closure) : gen_heap :=
fun (x : address) => if eq_nat_dec x a
  then Some clo
  else g x.

Definition alloc (g : heap) (addrs : addresses) (clos : list closure)
  : heap :=
fold_right (fun (ad : address * closure) (h : gen_heap) =>
  set h (fst ad) (snd ad))
  g (combine addrs clos).

Lemma set_eq :
forall H s v,
  set H s v s = Some v.
Proof with isa.
intros.
unfold set.
destruct (eq_nat_dec)...
tauto.
Qed.

Lemma set_neq :
forall H s v p
  (NEQ : p <> s),
  set H p v s = H s.
Proof with isa.
intros.
unfold set.
destruct eq_nat_dec...
symmetry in e.
intuition.
Qed.

Lemma alloc_in :
forall H vs v lfs lf
  (LEN   : length vs = length lfs)
  (IN    : In v vs)
  (ALLOC : alloc H vs lfs v = Some lf),
  In lf lfs.
Proof with isa.
induction vs...
contradiction.
destruct lfs; try discriminate...
inversion LEN as [ LEN0 ].
destruct (eq_nat_dec a v).
(* eq *)
subst...
unfold alloc in *...
rewrite set_eq in ALLOC.
inversion ALLOC as [ ALLOC0 ]; subst; auto.
(* neq *)
unfold alloc in *...
rewrite set_neq in ALLOC...
right; eapply IHvs; eauto.
fold (alloc H vs lfs) in ALLOC.
inversion IN...
contradiction.
Qed.

Lemma alloc_nin :
forall H vs p
  (NIN : ~ In p vs)
  lfs,
  alloc H vs lfs p = H p.
Proof with isa.
induction vs.
trivial.
assert (NOTIN : forall A p (x : A) xs,
  ~ In p (x :: xs) -> p <> x /\ ~ In p xs).
  isa.
intros.
apply NOTIN in NIN.
destruct NIN as [ NEQ NIN ].
destruct lfs...
unfold alloc...
rewrite set_neq...
fold (alloc H vs lfs)...
Qed.

Lemma alloc_some :
forall H a ats lfs
  (LEN : length ats = length lfs)
  (IN  : In a ats),
  exists r, alloc H ats lfs a = Some r.
Proof with isa.
induction ats...
contradiction.
unfold alloc in *.
destruct lfs; simpl in *; try discriminate.
unfold set in *.
destruct (eq_nat_dec a a0); subst.
(* eq *)
exists c...
(* neq *)
apply IHats.
inversion LEN...
destruct IN...
destruct n...
Qed.

Definition make_closure (e : env) (g : heap) (p : address)
  (cpvs : vars * code_pointer) : option closure :=
match cpvs with
| (vs, cp) =>
  match map_env e g p vs with
  | Some addrs => Some (cp, addrs)
  | None => None
  end
end.

Fixpoint make_closures (e : env) (g : heap) (p : address)
  (cps : list (vars * code_pointer)) {struct cps} : option closures:=
match cps with
| nil => Some nil
| cp::cps0 =>
  match make_closures e g p cps0 with
  | Some clos =>
    match make_closure e g p cp with
    | Some clo => Some (clo::clos)
    | None => None
    end
  | None => None
  end
end.

Reserved Notation " cs @@ a ^\ b " (at level 70, no associativity).

Inductive Sem (cs : code_store) : (action * stack) -> value -> Prop :=

| Halt : forall Value,
  cs @@ (A Value, nil) ^\ Value

| Cons : forall Gamma C xs sigma addrs cleanup args fake_bot pclo Value K
  (MAPENV  : map_env sigma Gamma pclo xs = Some addrs)
  (ARGSNIL : fake_bot = length args)
  (PREMISE : cs @@ (A (Val_con Gamma C addrs, (skipn cleanup sigma), (args, fake_bot)), K) ^\ Value),
  cs @@ (E (<< Gamma, Constr C xs (cleanup), sigma, (args, fake_bot), pclo >>), K) ^\ Value

| Accum : forall Gamma x xs sigma args p new_args Value cleanup fake_bot pclo K
  (MAPENV  : map_env sigma Gamma pclo xs = Some new_args)
  (LOOKUP  : look_up sigma Gamma pclo x = Some p)
  (PREMISE : cs @@ (E (<< Gamma, p, (new_args++args, fake_bot), skipn cleanup sigma >>), K) ^\ Value),
  cs @@ (E (<< Gamma, App x xs (cleanup), sigma, (args, fake_bot), pclo >>), K) ^\ Value

| App1 : forall cp Gamma p args clovars bind e some_clo sigma fake_bot real_args fake_args Value K
  (CS      : find_cs cs cp = CS_lf (Lf Dont_update clovars bind e))
  (ONHEAP  : Gamma p = Some (cp, some_clo))
  (REAL    : real_args = firstn (length args - fake_bot) args)
  (FAKE    : fake_args = skipn (length args - fake_bot) args)
  (LENGTH  : bind > length args - fake_bot)
  (PREMISE : cs @@ (A (Val_pap Gamma p real_args, sigma, (fake_args, fake_bot)), K) ^\ Value),
  cs @@ (E (<< Gamma, p, (args, fake_bot), sigma >>), K) ^\ Value

| App2 : forall cp Gamma p args Value e bind clo clovars sigma fake_bot K
  (CS      : find_cs cs cp = CS_lf (Lf Dont_update clovars bind e))
  (ONHEAP  : Gamma p = Some (cp, clo))
  (LENGTH  : bind <= length args - fake_bot)
  (PREMISE : cs @@ (E (<< Gamma, e, firstn bind args ++ sigma, (skipn bind args, fake_bot), p >>), K) ^\ Value),
  cs @@ (E (<< Gamma, p, (args, fake_bot), sigma >>), K) ^\ Value

| App_Eval : forall cp Gamma p args Value e clovars clo_e sigma fake_bot K
  (CS      : find_cs cs cp = CS_lf (Lf Update clovars 0 e))
  (ONHEAP1 : Gamma p = Some (cp, clo_e))
  (* NO CLOG !!! *)
  (PREMISE : cs @@ (E (<< Gamma, e, sigma, (args, length args), p >>), K_upd p fake_bot :: K) ^\ Value),
  cs @@ (E (<< Gamma, p, (args, fake_bot), sigma >>), K) ^\ Value

| App3 : forall p C addrs Delta theta args fake_bot fake_bot_dummy K Value
  (ARGSNIL : fake_bot = length args)
  (PREMISE : cs @@ (A (Val_con (set Delta p (CP_cons C (length addrs), addrs)) C addrs, theta, (args, fake_bot)), K) ^\ Value),
  cs @@ (A (Val_con Delta C addrs, theta, (args, fake_bot)), K_upd p fake_bot_dummy :: K) ^\ Value

| App4 : forall p Value q addrs Delta theta args0 fake_bot fake_bot0 K
  (PREMISE : cs @@ (E (<< set Delta p (CP_pap (length addrs), q :: addrs), q, (addrs++args0, fake_bot), theta >>), K) ^\ Value),
  cs @@ (A (Val_pap Delta q addrs, theta, (args0, fake_bot0)), K_upd p fake_bot :: K) ^\ Value

| Let : forall Gamma e lfs sigma closures Value addrs args pclo K
  (LENGTH  : length addrs = length lfs)
  (FRESH   : forall p : address, In p addrs -> Gamma p = None)
  (CLOS    : make_closures (addrs++sigma) Gamma pclo lfs = Some closures)
  (PREMISE : cs @@ (E (<< alloc Gamma addrs closures, e, addrs++sigma, args, pclo >>), K) ^\ Value),
  cs @@ (E (<< Gamma, Letrec lfs e, sigma, args, pclo >>), K) ^\ Value

| Case_of_Eval : forall Gamma e als sigma pclo Value args fake_bot K
  (PREMISE : cs @@ (E (<< Gamma, e, sigma, (args, length args), pclo >>), K_alt als fake_bot :: K) ^\ Value),
  cs @@ (E (<< Gamma, Case e als, sigma, (args, fake_bot), pclo >>), K) ^\ Value

| Case_of_Apply : forall p_als als pclo Value bind Delta p_e0 e0 C addrs theta args0 fake_bot fake_bot0 K
  (CS1     : find_cs cs p_als = CS_alts als)
  (SELECT  : nth C als = Some (Alt bind p_e0))
  (CS2     : find_cs cs p_e0 = CS_expr e0)
  (PREMISE : cs @@ (E (<< Delta, e0, addrs++theta, (args0, fake_bot), pclo >>), K) ^\ Value),
  cs @@ (A (Val_con Delta C addrs, theta, (args0, fake_bot0)), K_alt p_als fake_bot :: K) ^\ Value

where "cs @@ a ^\ b " := (Sem cs a b).