Cubicle BRAB in Why3 index


module Cubicle_BRAB

  use import ref.Ref
  use import option.Option
  use import fol.FOL
  use import abstract_queue.AbstractQueue as Q
  use import reachability.Reachability
  use import map.Map

  (* remove unecessary axioms for solvers *)
  meta remove_prop prop extensionality
  meta remove_prop prop structure_exists
  meta remove_prop prop model_true
  meta remove_prop prop model_false
  meta remove_prop prop model_and
  meta remove_prop prop model_or
  meta remove_prop prop model_neg
  meta remove_prop prop valid_def
  (* meta remove_prop prop and_a *)
  (* meta remove_prop prop and_c *)
  (* meta remove_prop prop or_a *)
  (* meta remove_prop prop or_c *)
  meta remove_prop prop sat_def
  (* meta remove_prop prop sat_or *)
  meta remove_prop prop sat_neg
  meta remove_prop prop sat_and
  meta remove_prop prop valid_or
  meta remove_prop prop valid_neg
  meta remove_prop prop valid_and
  meta remove_prop prop valid_sat
  meta remove_prop prop pre_star_def2
  meta remove_prop prop pre_star_def3
  meta remove_prop prop reachable_imply
  meta remove_prop prop reachable_and
  meta remove_prop prop pre_and
  meta remove_prop prop pre_or
  meta remove_prop prop unsat_invalid
  meta remove_prop prop model_extensionality
  meta remove_prop prop forget_subsumed_or
  
  
  type result = Safe | Unsafe
  exception Unsafe_trace

  type kind = Undef | Appr | Orig
  
  val visited : ref f
  val bad : ref f
  val faulty : ref f
  
  val q : Q.t

  constant finite_model : f
  val kind : ref (map f kind)
  val from : ref (map f f)
  

  val approx (phi : f) : option f
  reads { bad }
  ensures { match result with
            | Some psi -> not (!bad |== psi) /\ not (finite_model |== psi) /\
	      	       	  phi |== psi
	    | None -> true end }

  let pre_or_approx (tau: trans_rel) (phi : f) (ghost theta :f) (ghost init :f) =
    writes { kind, from }
    reads { bad }
    requires { (forall phi:f. !kind[phi] = Orig -> !from[phi] = theta) /\
	       (forall phi:f. !kind[phi] = Orig ->
	          reachable tau init phi -> reachable tau init !from[phi])}
    ensures { (
              (result = pre tau phi /\ !kind[result] = !kind[phi] /\ !from[result] = !from[phi])
    	      \/
              (phi |== result /\ !kind[result] = Appr /\
    	       (!kind[phi] = Orig -> !from[result] = result) /\
    	       (!kind[phi] = Appr -> !from[result] = !from[phi]))

	       (* /\ *)
	       (* (!kind[result] = Orig -> *)
	       (*    (!from[result] = !from[phi] /\ !kind[phi] = Orig )) /\ *)
	       (* (!kind[result] = Orig -> !from[result] = theta ) /\ *)
	       
	       (* (forall init:f. reachable init phi -> reachable init result) *)

	       ) &&

	       (forall phi:f. !kind[phi] = Orig -> !from[phi] = theta) &&
	       (forall phi:f. !kind[phi] = Orig ->
	          reachable tau init phi -> reachable tau init !from[phi])
	       }
    match approx phi with
      | Some psi ->
          kind := !kind[psi <- Appr];
	  if !kind[phi] = Orig then from := !from[psi <- psi]
	  else from := !from[psi <- !from[phi]];
          psi
      | None ->
          let psi = pre tau phi in
	  assert { reachable tau init psi -> reachable tau init phi };
          kind := !kind[psi <- !kind[phi]];
          from := !from[psi <- !from[phi]];
          psi
    end
  
    
  let bwd (tau: trans_rel)  (init : f) (theta : f) =
    writes { kind, from, visited, faulty, q }
    reads { bad }
    requires { forall psi:f. !kind[psi] = Undef /\ !from[psi] = psi }
    (* Soundness *)
    ensures { result = Safe -> not (reachable tau init theta) }
    ensures { result = Unsafe -> !kind[ !faulty ] = Orig -> reachable tau init theta }
    visited := ffalse;
    Q.clear q;
    try
       faulty := theta; (* just for init *)
       from := !from[ theta <- theta ];
       kind := !kind[ theta <- Orig ];
       if sat (init & theta) then raise Unsafe_trace;
       visited := theta ++ !visited;
       let pre_theta = pre tau theta in
       from := !from[ pre_theta <- theta ];
       kind := !kind[ pre_theta <- Orig ];       
       Q.push (pre_theta) q;
       while not (Q.is_empty q) do
        invariant { not (sat (!visited & init)) &&
                    (* pre_star !visited |== !visited ++ (pre_star q.formula) && *)
                    pre_star tau theta |== !visited ++ (pre_star tau q.formula) &&
	            (forall phi:f. !kind[phi] = Orig -> !from[phi] = theta) &&
	            (forall phi:f. !kind[phi] = Orig ->
		       reachable tau init phi -> reachable tau init (!from[phi]) )

		    (* (!kind[ !faulty ] = Orig -> !from[ !faulty ] = theta) && *)
		    (* (!kind[ !faulty ] = Orig -> reachable init !faulty -> reachable init (!from[ !faulty ])) *) }
        let ghost old_q = Q.copy q in
        let phi = Q.pop q in
        if sat (init & phi) then (faulty := phi; raise Unsafe_trace);
        if not (phi |== !visited) then (
          let ghost old_v = !visited in
          let ghost old_kind = !kind in
          let ghost old_from = !from in
          visited := phi ++ !visited;
          let poa = pre_or_approx tau phi theta init in
	  (* assert { (\* !kind[ phi ] = Orig -> !from[phi] = theta && *\) *)
	  (*        (\* (!kind[phi] = Orig -> phi <> theta -> *\) *)
	  (* 	 (\*       reachable init phi -> reachable init (!from[phi])) *\) *)
	  (* 	  }; *)
          Q.push poa q;
          assert {
	           old_v ++ pre_star tau q.formula |==
		     old_v ++ (pre_star tau phi ++ pre_star tau q.formula)

		   &&
		   
		   (phi ++ old_v) ++ pre_star tau (pre tau phi ++ ((~ phi) & old_q.formula)) =
		     old_v ++ (pre_star tau phi ++ pre_star tau (~ phi & old_q.formula))

		   &&
		   
		   (phi ++ old_v) ++ pre_star tau (pre tau phi ++ ((~ phi) & old_q.formula)) =
		     old_v ++ pre_star tau (ttrue & (phi ++ old_q.formula))
		     
		   &&

		   (phi |== poa ->
		     ((phi ++ old_v) ++
		      (pre_star tau phi ++ pre_star tau (~ phi & old_q.formula))) |==
		     ((phi ++ old_v) ++ (pre_star tau poa ++
		       pre_star tau (~ phi & old_q.formula))))
		     
		 }

        )
        else
           assert {
	        valid ((~ phi) => pre_star tau (~ phi))

                &&
		
		!visited ++ ((~ phi) ++ (pre_star tau (~ phi))) =
        	  (phi ++ !visited) ++ ((~ phi) ++ (pre_star tau (~ phi)))
		  
                &&
		

		 ((!visited ++ (~ phi ++ pre_star tau (~ phi)))
		   & (!visited ++ pre_star tau old_q.formula)) = 
                 ((!visited ++  ((phi ++ ~ phi) ++ pre_star tau (~ phi))) &
		   (!visited ++ pre_star tau old_q.formula))
		   
                &&
		

		 ((!visited ++ (~ phi ++ pre_star tau (~ phi)))
		   & (!visited ++ pre_star tau old_q.formula)) = 
                 ((!visited ++  (ttrue ++ pre_star tau (~ phi))) &
		   (!visited ++ pre_star tau old_q.formula))

		&&

		 ((!visited ++ (~ phi ++ pre_star tau (~ phi)))
		   & (!visited ++ pre_star tau old_q.formula)) = 
		 (!visited ++ ttrue) & (!visited ++ pre_star tau old_q.formula)
          }
        
       done;
      Safe
    with
        | Unsafe_trace -> Unsafe
        | Q.Empty -> absurd
    end


    val reset_maps (theta : f) : unit writes { kind, from }
       ensures { forall psi:f. !kind[psi] = Undef /\ !from[psi] = psi }

    val bwd_res : ref result
    
    let brab (tau: trans_rel) (init : f) (theta : f) =
        requires { forall psi:f. !kind[psi] = Undef /\ !from[psi] = psi }
	ensures { result = Safe -> not (reachable tau init theta) }
	ensures { result = Unsafe -> reachable tau init theta }
    	bad := ffalse;
	try
	    bwd_res := bwd tau init theta;
	    while !bwd_res = Unsafe do
                invariant { !bwd_res = Safe -> not (reachable tau init theta) }
                invariant { !bwd_res = Unsafe ->
		                !kind[ !faulty ] = Orig -> reachable tau init theta }
	        if !kind[ !faulty ] = Orig then raise Unsafe_trace;
	    	bad := !from[ !faulty ] ++ !bad;
		reset_maps theta;
	        bwd_res := bwd tau init theta
	    done;
	    Safe
        with
            Unsafe_trace -> Unsafe
	end


end

Generated by why3doc 0.82+git