Theory Quicksort_concept

(******************************************************************************
 * Clean
 *
 * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************)

(*
 * Quicksort Concept 
 *
 * Authors : Burkhart Wolff, Frédéric Tuong
 *)

chapter ‹ Clean Semantics : A Coding-Concept Example›

text‹The following show-case introduces subsequently a non-trivial example involving
local and global variable declarations, declarations of operations with pre-post conditions as
well as direct-recursive operations (i.e. C-like functions with side-effects on global and
local variables. ›

theory Quicksort_concept
  imports Clean.Clean
          Clean.Hoare_Clean
          Clean.Clean_Symbex
begin

section‹The Quicksort Example›

text‹ We present the following quicksort algorithm in some conceptual, high-level notation:

\begin{isar}
algorithm (A,i,j) =
    tmp := A[i];
    A[i]:=A[j];
    A[j]:=tmp

algorithm partition(A, lo, hi) is
    pivot := A[hi]
    i := lo
    for j := lo to hi - 1 do
        if A[j] < pivot then
            swap A[i] with A[j]
            i := i + 1
    swap A[i] with A[hi]
    return i

algorithm quicksort(A, lo, hi) is
    if lo < hi then
        p := partition(A, lo, hi)
        quicksort(A, lo, p - 1)
        quicksort(A, p + 1, hi)

\end{isar}
›

text‹In the following, we will present the Quicksort program alternatingly in Clean high-level
notation and simulate its effect by an alternative formalisation representing the semantic
effects of the high-level notation on a step-buy-step basis. Note that Clean does not posses
the concept of call-by-reference parameters; consequently, the algorithm must be specialized 
to a variant where @{term A} is just a global variable.›

section‹Clean Encoding of the Global State of Quicksort›

text‹We demonstrate the accumulating effect of some key Clean commands by highlighting the 
changes of  Clean's state-management module state. At the beginning, the state-type of 
the Clean state management is just the type of the @{typ "'a Clean.control_state.control_state_ext"},
while the table of global and local variables is empty.›

MLval Type(s,t) = StateMgt_core.get_state_type_global @{theory};
    StateMgt_core.get_state_field_tab_global @{theory};

text‹The global_vars› command, described and defined in ‹Clean.thy›,
declares the global variable ‹A›. This has the following effect:›


global_vars (S)
    A :: "int list"
ML(fst o  StateMgt_core.get_data_global) @{theory}
global_vars (S2)
    B :: "int list"


ML(Int.toString o length o Symtab.dest o fst o  StateMgt_core.get_data_global) @{theory}

find_theorems (60) name:global_state2_state

find_theorems createL name:"Quick"

text‹... which is reflected in Clean's state-management table:›
MLval Type("Quicksort_concept.global_S2_state_scheme",t) 
        = StateMgt_core.get_state_type_global @{theory};
    (Int.toString o length o Symtab.dest)(StateMgt_core.get_state_field_tab_global @{theory})


text‹Note that the state-management uses long-names for complete disambiguation.›


subsubsection‹A Simulation of Synthesis of Typed Assignment-Rules›
definition AL' where "AL'  createL global_S_state.A global_S_state.A_update"

lemma  AL'_control_indep : "(break_statusL  AL'  return_statusL  AL')"
  unfolding AL'_def break_statusL_def return_statusL_def createL_def upd2put_def
  by (simp add: lens_indep_def)

lemma AL'_strong_indep : "♯! AL'"
  unfolding strong_control_independence_def
  using AL'_control_indep by blast


text‹Specialized Assignment Rule for Global Variable A›.
Note that this specialized rule of @{thm assign_global} does not
need any further side-conditions referring to independence from the control.
Consequently, backward inference in an wp›-calculus will just maintain
the invariant @{term ¬ exec_stop σ}.›
lemma assign_global_A:
     "λσ.  σ   P (σA := rhs σ)  A_update :==G rhs λr σ.  σ  P σ "
     apply(rule assign_global)
     apply(rule strong_vs_weak_upd [of global_S_state.A global_S_state.A_update])
     apply (metis AL'_def AL'_strong_indep)
     by(rule ext, rule ext, auto)

section ‹Encoding swap in Clean›

subsection ‹swap› in High-level Notation›

text‹Unfortunately, the name result› is already used in the logical context; we use local binders
instead.›
definition "i = ()" ― ‹check that termi can exist as a constant with an arbitrary type before treating function_spec
definition "j = ()" ― ‹check that termj can exist as a constant with an arbitrary type before treating function_spec

function_spec swap (i::nat,j::nat) ― ‹TODO: the hovering on parameters produces a number of report equal to the number of MLProof_Context.add_fixes called in MLFunction_Specification_Parser.checkNsem_function_spec
pre          "‹i < length A ∧ j < length A›"    
post         "‹λres. length A = length(old A) ∧ res = ()›" 
local_vars   tmp :: int 
defines      " ‹ tmp := A ! i›  ;-
               ‹ A := list_update A i (A ! j)› ;- 
               ‹ A := list_update A j tmp› " 

value "break_status = False, return_status = False, A = [1,2,3], 
       tmp = [], result_value = [],  = X"

term swap

find_theorems (70) name:"local_swap_state"

value "swap (0,1) break_status = False, return_status = False, A = [1,2,3], B=[],
                   tmp = [],
                   result_value = [], = X"  

text‹The body --- heavily using the λ›-lifting cartouche --- corresponds to the 
     low level term: ›

text@{cartouche [display=true]
‹‹defines " ((assign_local tmp_update (λσ. (A σ) ! i ))   ;-
             (assign_global A_update (λσ. list_update (A σ) (i) (A σ ! j))) ;- 
             (assign_global A_update (λσ. list_update (A σ) (j) ((hd o tmp) σ))))"››}

text‹The effect of this statement is generation of the following definitions in the logical context:›
term "(i, j)" ― ‹check that termi and termj are pointing to the constants defined before treating function_spec
thm push_local_swap_state_def
thm pop_local_swap_state_def
thm swap_pre_def
thm swap_post_def
thm swap_core_def
thm swap_def

text‹The state-management is in the following configuration:›

MLval Type(s,t) = StateMgt_core.get_state_type_global @{theory};
    StateMgt_core.get_state_field_tab_global @{theory}

subsection ‹A Similation of ‹swap› in elementary specification constructs:›

text‹Note that we prime identifiers in order to avoid confusion with the definitions of the
previous section. The pre- and postconditions are just definitions of the following form:›

definition swap'_pre :: " nat × nat  'a global_S_state_scheme  bool"
  where   "swap'_pre  λ(i, j) σ. i < length (A σ)  j < length (A σ)"
definition swap'_post :: "'a × 'b  'c global_S_state_scheme  'd global_S_state_scheme  unit  bool"
  where   "swap'_post  λ(i, j) σpre σ res. length (A σ) = length (A σpre)  res = ()"
text‹The somewhat vacuous parameter res› for the result of the swap-computation is the conseqeuence 
of the implicit definition of the return-type as @{typ "unit"}

text‹We simulate the effect of the local variable space declaration by the following command
     factoring out the functionality into the command local_vars_test›


local_vars_test (swap' "unit")
   tmp :: "int"

text‹The immediate effect of this command on the internal Clean State Management
can be made explicit as follows: ›
MLval Type(s,t) = StateMgt_core.get_state_type_global @{theory};
val tab = StateMgt_core.get_state_field_tab_global @{theory};
@{term "A::('a local_swap_state_scheme int list)"}

text‹This has already the effect of the definition:›
thm push_local_swap_state_def
thm pop_local_swap_state_def

text‹Again, we simulate the effect of this command by more elementary \HOL specification constructs:›
(* Thus, the internal functionality in ‹local_vars› is the construction of the two definitions *)
definition push_local_swap_state' :: "(unit,'a local_swap'_state_scheme) MONSE"
  where   "push_local_swap_state' σ = 
                    Some((),σlocal_swap'_state.tmp :=  undefined # local_swap'_state.tmp σ )"

definition pop_local_swap_state' :: "(unit,'a local_swap'_state_scheme) MONSE"
  where   "pop_local_swap_state' σ = 
                    Some(hd(local_swap_state.result_value σ), 
                                ― ‹ recall : returns op value ›
                                ― ‹ which happens to be unit ›
                         σlocal_swap_state.tmp:= tl( local_swap_state.tmp σ) )"


definition swap'_core :: "nat × nat   (unit,'a local_swap'_state_scheme) MONSE"
  where "swap'_core   (λ(i,j). 
                            ((assign_local tmp_update (λσ. A σ ! i ))   ;-
                            (assign_global A_update (λσ. list_update (A σ) (i) (A σ ! j))) ;- 
                            (assign_global A_update (λσ. list_update (A σ) (j) ((hd o tmp) σ)))))" 

text‹ a block manages the "dynamically" created fresh instances for the local variables of swap ›
definition swap' :: "nat × nat   (unit,'a local_swap'_state_scheme) MONSE"
  where   "swap'  λ(i,j). blockC push_local_swap_state' (swap_core (i,j)) pop_local_swap_state'"


text‹NOTE: If local variables were only used in single-assignment style, it is possible
   to drastically simplify the encoding. These variables were not stored in the state,
   just kept as part of the monadic calculation. The simplifications refer both to 
   calculation as well as well as symbolic execution and deduction.›

text‹The could be represented by the following alternative, optimized version :›
definition swap_opt :: "nat × nat   (unit,'a global_S_state_scheme) MONSE"
    where "swap_opt  λ(i,j). (tmp   yieldC (λσ. A σ ! i) ;
                          ((assign_global A_update (λσ. list_update (A σ) (i) (A σ ! j))) ;- 
                           (assign_global A_update (λσ. list_update (A σ) (j) (tmp)))))" 
text‹In case that all local variables are single-assigned in swap, the entire local var definition
   could be ommitted.›

text‹A more pretty-printed term representation is:›
termswap_opt = (λ(i, j).
               tmp  (yieldC (λσ. A σ ! i));
               (A_update :==G (λσ. (A σ)[i := A σ ! j]) ;- 
                A_update :==G (λσ. (A σ)[j := tmp])))


subsubsection‹A Simulation of Synthesis of Typed Assignment-Rules›

definition tmpL 
  where "tmpL  createL local_swap'_state.tmp local_swap'_state.tmp_update"

lemma  tmpL_control_indep : "(break_statusL  tmpL  return_statusL  tmpL)"
  unfolding tmpL_def break_statusL_def return_statusL_def createL_def upd2put_def
  by (simp add: lens_indep_def)

lemma tmpL_strong_indep : "♯! tmpL"
  unfolding strong_control_independence_def
  using tmpL_control_indep by blast

text‹Specialized Assignment Rule for Local Variable tmp›.
Note that this specialized rule of @{thm assign_local} does not
need any further side-conditions referring to independence from the control.
Consequently, backward inference in an wp›-calculus will just maintain
the invariant @{term  σ}.›

lemma assign_local_tmp:
   "λσ.  σ  P ((tmp_update  upd_hd) (λ_. rhs σ) σ)  
    local_swap'_state.tmp_update :==L rhs 
    λr σ.  σ  P σ "
   apply(rule assign_local)
   apply(rule strong_vs_weak_upd_list)
    apply(rule tmpL_strong_indep[simplified tmpL_def])
   by(rule ext, rule ext, auto)  


section ‹Encoding ‹partition› in Clean›

subsection ‹partition› in High-level Notation›

function_spec partition (lo::nat, hi::nat) returns nat
pre          "‹lo < length A ∧ hi < length A›"    
post         "‹λres::nat. length A = length(old A) ∧ res = 3›" 
local_vars   pivot  :: int
             i      :: nat
             j      :: nat
defines      " ‹pivot := A ! hi ›  ;- ‹i := lo › ;- ‹j := lo › ;-
               (whileC ‹j ≤ hi - 1 › 
                do (ifC ‹A ! j < pivot›  
                    then  callC swap ‹(i , j) ›  ;-
                          ‹i := i + 1 ›
                    else skipSE 
                    fi) ;-
                    ‹j := j + 1 › 
                od) ;-
                callC swap ‹(i, j)›  ;-
                returnC result_value_update ‹i›" 

text‹ The body is a fancy syntax for :

@{cartouche [display=true]
‹‹defines      " ((assign_local pivot_update (λσ. A σ ! hi ))   ;- 
               (assign_local i_update (λσ. lo )) ;-
 
               (assign_local j_update (λσ. lo )) ;-
               (whileC (λσ. (hd o j) σ ≤ hi - 1 ) 
                do (ifC (λσ. A σ ! (hd o j) σ < (hd o pivot)σ ) 
                    then  callC (swap) (λσ. ((hd o i) σ,  (hd o j) σ))  ;-
                          assign_local i_update (λσ. ((hd o i) σ) + 1)
                    else skipSE 
                    fi) ;-
                    (assign_local j_update (λσ. ((hd o j) σ) + 1)) 
                od) ;-
                callC (swap) (λσ. ((hd o i) σ,  (hd o j) σ))  ;-
                assign_local result_value_update (λσ. (hd o i) σ)  
                ― ‹ the meaning of the return stmt ›
               ) "››}


text‹The effect of this statement is generation of the following definitions in the logical context:›
thm partition_pre_def
thm partition_post_def
thm push_local_partition_state_def
thm pop_local_partition_state_def
thm partition_core_def
thm partition_def

text‹The state-management is in the following configuration:›

MLval Type(s,t) = StateMgt_core.get_state_type_global @{theory};
    StateMgt_core.get_state_field_tab_global @{theory}

subsection ‹A Similation of ‹partition› in elementary specification constructs:›

subsubsection ‹Contract-Elements›
definition "partition'_pre  λ(lo, hi) σ. lo < length (A σ)  hi < length (A σ)"
definition "partition'_post  λ(lo, hi) σpre σ res. length (A σ) = length (A σpre)  res = 3"


subsubsection‹Memory-Model›
text‹Recall: list-lifting is automatic in local_vars_test›:›

local_vars_test  (partition' "nat")
    pivot  :: "int"
    i      :: "nat"
    j      :: "nat"

text‹ ... which results in the internal definition of the respective push and pop operations 
for the @{term "partition'"} local variable space: ›

thm push_local_partition'_state_def
thm pop_local_partition'_state_def

(* equivalent to *)
definition push_local_partition_state' :: "(unit, 'a local_partition'_state_scheme) MONSE"
  where   "push_local_partition_state' σ = Some((),
                        σlocal_partition_state.pivot := undefined # local_partition_state.pivot σ, 
                          local_partition_state.i     := undefined # local_partition_state.i σ, 
                          local_partition_state.j     := undefined # local_partition_state.j σ, 
                          local_partition_state.result_value   
                                           := undefined # local_partition_state.result_value σ )"

definition pop_local_partition_state' :: "(nat,'a local_partition_state_scheme) MONSE" 
  where   "pop_local_partition_state' σ = Some(hd(local_partition_state.result_value σ),
                       σlocal_partition_state.pivot := tl(local_partition_state.pivot σ), 
                         local_partition_state.i     := tl(local_partition_state.i σ), 
                         local_partition_state.j     := tl(local_partition_state.j σ), 
                         local_partition_state.result_value := 
                                                        tl(local_partition_state.result_value σ) )"

subsubsection‹Memory-Model›
text‹Independence of Control-Block:›


subsubsection‹Monadic Representation of the Body›

definition partition'_core :: "nat × nat   (unit,'a local_partition'_state_scheme) MONSE"
  where   "partition'_core   λ(lo,hi).
              ((assign_local pivot_update (λσ. A σ ! hi ))   ;- 
               (assign_local i_update (λσ. lo )) ;-
 
               (assign_local j_update (λσ. lo )) ;-
               (whileC (λσ. (hd o j) σ  hi - 1 ) 
                do (ifC (λσ. A σ ! (hd o j) σ < (hd o pivot)σ ) 
                    then  callC (swap) (λσ. ((hd o i) σ,  (hd o j) σ))  ;-
                          assign_local i_update (λσ. ((hd o i) σ) + 1)
                    else skipSE 
                    fi) 
                od) ;-
               (assign_local j_update (λσ. ((hd o j) σ) + 1)) ;-
                callC (swap) (λσ. ((hd o i) σ,  (hd o j) σ))  ;-
                assign_local result_value_update (λσ. (hd o i) σ)  
                ― ‹ the meaning of the return stmt ›
               )"

thm partition_core_def

(* a block manages the "dynamically" created fresh instances for the local variables of swap *)
definition partition' :: "nat × nat   (nat,'a local_partition'_state_scheme) MONSE"
  where   "partition'   λ(lo,hi). blockC push_local_partition_state 
                                   (partition_core (lo,hi)) 
                                   pop_local_partition_state"
             

section ‹Encoding the toplevel : ‹quicksort› in Clean›

subsection ‹quicksort› in High-level Notation›

rec_function_spec quicksort (lo::nat, hi::nat) returns unit
pre          "‹lo ≤ hi ∧ hi < length A›"
post         "‹λres::unit. ∀i∈{lo .. hi}. ∀j∈{lo .. hi}. i ≤ j ⟶ A!i ≤ A!j›"
variant      "hi - lo" 
local_vars   p :: "nat" 
defines      " ifC ‹lo < hi›  
               then (ptmp  callC partition ‹(lo, hi)› ; assign_local p_update (λσ. ptmp)) ;-
                     callC quicksort ‹(lo, p - 1)› ;-
                     callC quicksort ‹(lo, p + 1)›  
               else skipSE 
               fi"


thm quicksort_core_def
thm quicksort_def
thm quicksort_pre_def
thm quicksort_post_def




subsection ‹A Similation of ‹quicksort› in elementary specification constructs:›

text‹This is the most complex form a Clean function may have: it may be directly 
recursive. Two subcases are to be distinguished: either a measure is provided or not.›

text‹We start again with our simulation: First, we define the local variable p›.›
local_vars_test  (quicksort' "unit")
    p  :: "nat"

MLval (x,y) = StateMgt_core.get_data_global @{theory};

thm pop_local_quicksort'_state_def
thm push_local_quicksort'_state_def

(* this implies the definitions : *)
definition push_local_quicksort_state' :: "(unit, 'a local_quicksort'_state_scheme) MONSE"
  where   "push_local_quicksort_state' σ = 
                 Some((), σlocal_quicksort'_state.p := undefined # local_quicksort'_state.p σ,
                            local_quicksort'_state.result_value := undefined # local_quicksort'_state.result_value σ )"




definition pop_local_quicksort_state' :: "(unit,'a local_quicksort'_state_scheme) MONSE"
  where   "pop_local_quicksort_state' σ = Some(hd(local_quicksort'_state.result_value σ),
                       σlocal_quicksort'_state.p   := tl(local_quicksort'_state.p σ), 
                         local_quicksort'_state.result_value := 
                                                      tl(local_quicksort'_state.result_value σ) )"

text‹We recall the structure of the direct-recursive call in Clean syntax:
@{cartouche [display=true]
‹
funct quicksort(lo::int, hi::int) returns unit
     pre  "True"
     post "True"
     local_vars p :: int     
     ‹ifCLEAN ‹lo < hi› then
        p := partition(lo, hi) ;-
        quicksort(lo, p - 1) ;-
        quicksort(p + 1, hi)
      else Skip›
›}


definition quicksort'_pre :: "nat × nat  'a local_quicksort'_state_scheme    bool"
  where   "quicksort'_pre  λ(i,j). λσ.  True "

definition quicksort'_post :: "nat × nat  unit  'a local_quicksort'_state_scheme   bool"
  where   "quicksort'_post  λ(i,j). λ res. λσ.  True"   


definition quicksort'_core :: "   (nat × nat  (unit,'a local_quicksort'_state_scheme) MONSE)
                               (nat × nat  (unit,'a local_quicksort'_state_scheme) MONSE)"
  where   "quicksort'_core quicksort_rec  λ(lo, hi). 
                            ((ifC (λσ. lo < hi ) 
                              then (ptmp  callC partition (λσ. (lo, hi)) ;
                                    assign_local p_update (λσ. ptmp)) ;-
                                    callC quicksort_rec (λσ. (lo, (hd o p) σ - 1)) ;-
                                    callC quicksort_rec (λσ. ((hd o p) σ + 1, hi))  
                              else skipSE 
                              fi))"

term " ((quicksort'_core X) (lo,hi))"

definition quicksort' :: " ((nat × nat) × (nat × nat)) set 
                            (nat × nat  (unit,'a local_quicksort'_state_scheme) MONSE)"
  where   "quicksort' order  wfrec order (λX. λ(lo, hi). blockC push_local_quicksort'_state 
                                                                 (quicksort'_core X (lo,hi)) 
                                                                 pop_local_quicksort'_state)"


subsection‹Setup for Deductive Verification›

text‹The coupling between the pre- and the post-condition state is done by the 
     free variable (serving as a kind of ghost-variable) @{term "σpre"}. This coupling
     can also be used to express framing conditions; i.e. parts of the state which are
     independent and/or not affected by the computations to be verified. ›
lemma quicksort_correct : 
  "λσ.    σ  quicksort_pre (lo, hi)(σ)  σ = σpre  
     quicksort (lo, hi) 
   λr σ.  σ  quicksort_post(lo, hi)(σpre)(σ)(r) "
   oops



end